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NOAA  TECHNICAL  MEMORANDUM 

National  Weather  Service,  Eastern  Region  Computer  Programs  and  Problems 

The  Eastern  Region  Computer  Programs  and  Problems  (ERCP)  series  is  a  sub¬ 
set  of  the  Eastern  Region  Technical  Memorandum  series.  It  will  serve  as 
the  vehicle  for  the  transfer  of  information  about  fully  documented  AFOS 
application  programs.  The  format  ERCP  -  No.  1  will  serve  as  the  model 
for  future  issuances  in  this  series. 

1  An  AFOS  version  of  the  Flash  Flood  Checklist.  Cynthia  M.  Scott, 

March  1981.  (PB81  211252). 

2  An  AFOS  Applications  Program  to  Compute  Three-Hourly  Stream  Stages. 

Alan  P.  Blackburn,  September  1981.  (PB82  156886). 

3  PUPPY  (AFOS  Hydrologic  Data  Reporting  Program).  Daniel  P.  Provost, 

December  1981.  (PB82  199720). 

4  Special  Search  Computer  Program.  Alan  P.  Blackburn,  April  1982. 

(PB83  175455). 

5  Conversion  of  ALEMBICS  Workbins.  Alan  P.  Blackburn,  October  1982. 

(PB83  138313). 

6  Real-Time  Quality  Control  of  SAOs .  John  A.  Billet,  January  1983. 

(PB83  166082). 

7  Automated  Hourly  Weather  Collective  from  HRR  Data  Input.  Lawrence 

Cedrone,  January  1983  (PB83  167122). 

8  Decoders  for  FRH,  FTJ  and  FD  Products.  Cynthia  M.  Scott,  February  1983. 
(PB83  176057). 

9  Stability  Analysis  Program.  Hugh  M.  Stone,  March  1983.  (PB83  197947). 

10  Help  for  AFOS  Message  Comp.  Alan  P.  Blackburn,  May  1983.  (PB83  213561). 

11  Stability  and  Other  Parameters  from  the  First  Transmission  RAOB  Data. 

Charles  D.  Little,  May  1983.  (PB83  220475). 

12  TERR,  PERR,  and  BIGC:  Three  Programs  to  Compute  Verification  Statistics 

Matthew  R.  Peroutka,  August  1983.  (PB84  127521). 

13  Decoder  for  Manually  Digitized  Radar  Observations.  Matthew  R.  Peroutka, 

June  1983.  (PB84  127539). 

14  Slick  and  Quick  Data  Entry  for  AFOS  Era  Verification  (AEV)  Program. 

Alan  P.  Blackburn,  December  1983.  (PB84  138726). 

15  MDR--Processing  Manually  Digitized  Radar  Observations.  Matthew  R. 
Peroutka,  November  1983. 


RANP 

STABILITY  ANALYSIS  PLOT  PROGRAM 


Hugh  M.  Stone 

Scientific  Services  Division 
National  Weather  Service  Eastern  Region 
Garden  City,  New  York 


I.  General  Information 

A.  Summary 

New  indicators  of  static  stability,  the  energy  indices  Ell  and  EI2,  are 
now  available  (Stone,  1983)  and  may  be  computed  with  the  AFOS  application 
program  RAN.  These  indices,  formerly  called  B1  and  B2,  are  based  on  the 
change  of  kinetic  energy  of  a  parcel  as  it  moves  upward  through  the  atmos¬ 
phere  entraining  environmental  air  during  its  ascent.  Unlike  the  more 
traditional  stability  indices,  i.e.  Lifted,  K,  Showalter,  etc.,  which  use 
only  a  few  levels  of  the  sounding,  the  energy  indices  utilize  all  the 
information  in  significant  level  sounding  (UJ1)  and  should  provide  a 
more  accurate  measure  of  static  stability. 

The  RAN  program  computes  the  Ell  and  EI2  indices,  the  equilibrium  level, 
a  variety  of  other  traditional  stability  indices,  and  several  other 
parameters,  which  can  be  derived  from  significant  level  raob  data;  the 
computation  is  done  for  a  single  raob  station.  For  many  purposes,  the 
geographical  distribution  of  these  parameters  is  more  important  than  a 
point  value.  The  RANP  program  does  the  same  computation  as  RAN,  but 
instead  of  using  a  single  raob  station,  the  computation  may  be  done  for 
a  group  of  stations  specified  in  a  list.  The  output  consists  of  tabulated 
values  for  12  parameters  and  a  graphic  with  plotted  values  of  two  of  the 
most  important  parameters,  the  Ell  index  and  the  equilibrium  level  EL. 

A  switch  has  been  provided  so  RANP  can  also  be  run  for  a  single  station 
specified  in  the  RUN  line.  In  this  case,  the  output  is  identical  to  that 
provided  by  the  RAN  program  and  provides  a  detailed  analysis  of  the 
significant  level  raob  sounding.  The  RAN  program  may  therefore  be 
replaced  by  RANP. 

RANP  was  developed  to  run  on  an  Eclipse  S/230  minicomputer.  Language  used 
is  Data  General  FORTRAN  IV. 

II.  Application 

A.  Program  Description 

The  motivation  for  the  development  of  the  energy  indices  Ell  and  EI2 
(formerly  B1  and  B2)  and  the  method  of  computation  has  already  been 
given  in  ERCP  No.  9  (Stone,  1983).  Experience  with  these  indices  during 
the  1983  convective  season  suggested  that  the  entrainment  rate  used  in 
the  computation  was  excessive.  The  Ell  index  had  a  bias  toward  stable 
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conditions  with  convection  occasionally  beginning  with  values  of  Ell  as 
low  as  -80.  Likewise,  equilibrium  levels  seemed  to  be  too  low. 

Changes  in  the  entrainment  rate  have  now  been  made  to  help  correct  these 
defects.  The  method  of  computation  is  still  the  same  except  that  the 
entrainment  rate  for  the  energy  index  computation  has  been  reduced  from 
100  percent  to  60  percent.  This  means  a  60  percent  increase  in  mass  of 
the  parcel  over  a  500mb  ascent  rather  than  the  doubling  of  mass  used 
previously.  We  are  still  not  sure  this  is  the  best  entrainment  rate  and 
it  may  need  to  be  changed  again. 

Changing  the  entrainment  rate  from  100  to  60  percent  usually  has  the 
effect  of  making  unstable  indices  more  unstable,  slightly  stable  indices 
become  unstable,  and  very  stable  indices  can  go  either  way  depending  on 
the  moisture  distribution. 

The  equilibrium  level  is  now  computed  separately  using  a  zero  entrainment 
rate.  The  interior  portions  of  large  thunderstorms  that  may  produce 
severe  weather  are  virtually  unaffected  by  the  entrainment  process. 

Since  the  radar  tops  of  large  storms  are  compared  to  the  equilibrium  level 
to  assess  their  potential  for  severe  weather,  we  believe  the  zero  entrain¬ 
ment  rate  is  appropriate. 

The  EI2  index  was  previously  defined  (Stone,  1983)  as  the  change  in 
kinetic  energy  of  a  parcel  as  it  moves  from  the  level  of  maximum 
instability  (PMAX)  to  the  equilibrium  level.  This  definition  is  still 
correct  provided  that  the "equi 1 ibrium  level"  is  computed  with  entrainment; 
it  is  not  the  equilibrium  level  EL  that  appears  in  the  output. 

The  equilibrium  level  EL  is  first  determined  in  pressure  units  then  the 
mandatory  level  raob  transmission  (US1)  is  used  to  interpolate  a  value 
in  feet,  which  makes  it  easier  to  compare  to  radar  tops  which  are  also 
reported  in  feet.  If  the  mandatory  levels  are  missing  for  any  reason, 
the  interpolation  is  done  using  the  U.S.  Standard  Atmosphere,  with  the 
value  followed  by  an  "E"  in  the  output  to  indicate  estimated.  The  same 
procedure  is  used  for  tropopause  height  which  is  read  from  the  mandatory 
level  transmission  and  converted  to  feet  for  comparison  to  the  equilibrium 
level.  Both  equilibrium  level  and  tropopause  height  in  hundreds  of  feet 
are  given  in  the  AF0S  product  WRKTPC  (figure  1). 

The  following  parameters  are  included  in  the  AF0S  product  WRKTPC: 

P0  surface  pressure  (mb) 

PMAX  pressure  (mb)  of  highest  wet  bulb  potential  temperature 
in  the  lowest  150mb  of  the  sounding.  Starting  point 
of  parcel  ascent. 

EL  Equilibrium  level  in  (mb)  and  (Ft.  X  102) 

TR0P  Tropopause  level  (Ft.  X  10^) 

Ell  Energy  Index  1.  Change  in  kinetic  energy  of  parcel 
moving  from  level  PMAX  to  400mb  level.  (J/Kg  X  10) 

EI2  Energy  Index  2.  Change  in  kinetic  energy  of  parcel 
moving  from  level  PMAX  to  the  "equilibrium  level 
computed  with  entrainment"  (J/Kg  X  10) 
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LI 

Lifted  Index  (°C) 

KI 

K  Index  (°C) 

SWI 

Showalter  Index  (°C) 

CCL 

Convective  Condensation  Level  (mb) 

ETCCL 

Amount  of  low  level  heating  required  for 

surface  parcel  to 

ascend  dry  adiabatical  ly  to  CCL  level. 

(J/Kg  X  10) 

Missing  values  indicated  by 

Two  of  the  most  important  parameters,  the  energy  indexEIland  the  equili¬ 
brium  level  EL  in  hundreds  of  feet,  are  plotted  on  the  AFOS  graphic 
NMCGPHEIS  (figure  2).  Ell  appears  to  the  upper  right  of  the  station  circle 
and  EL  to  the  upper  left.  Positive  (unstable)  values  of  Ell  are  plotted 
with  a  solid  station  circle  and  negative  (stable)  values  with  an  open 
station  circle.  The  graphic  EIS  uses  map  background  2,  North  America. 

A  zoom  of  4:1  or  more  must  be  used.  The  raob  stations  used  in  the  computa¬ 
tion  must  be  listed  in  the  RDOS  file  STNSl  (figure  3). 

If  RANP  is  run  for  a  single  station,  the  output  goes  into  AFOS  products 
WRKTPA  (figure  4)  and  WRKTPB  (figure  5).  These  are  the  same  products 
created  by  the  program  RAN  and  have  the  same  format,  which  was  explained 
in  ERCP  No.  9  (Stone,  1983). 

B.  Machine  Requirements 

Using  a  list  of  32  raob  stations,  covering  approximately  the  eastern  third 
of  the  United  States,  the  total  runtime  is  usually  around  8  minutes.  Two 
FORTRAN  channels  are  open  during  the  program  run.  One  RDOS  channel  is 
used  at  the  end  of  the  computation  to  insert  headings  and  endings  for  the 
AFOS  alphanumeric  products.  Disk  space  required  for  the  program  RANP.SV  is 
122  RDOS  blocks  with  an  accompanying  overlay  file  RANP.OL  occupying  28  RDOS 
blocks . 

C.  Database 

Products  that  are  referenced: 

1.  CCCSGLXXX  :  significant  level  raob  soundings  listed  in  file  STNSl  or 
given  in  run  line. 

2.  CCCMANXXX  :  corresponding  mandatory  level  raob  soundings.  If  these 
are  not  available  for  any  reason,  the  program  will  still  run,  but  a 
U.S.  Standard  Atmosphere  will  be  assumed  in  the  computation  of 
equilibrium  level  in  feet  and  tropopause  height  will  be  missing. 

Files/products  that  are  created: 

1.  INDEXX  :  temporary  storage  file  for  data  that  are  eventually  stored 
as  AFOS  products  WRKTPA,  WRKTPC,  or  WRKTPD.  INDEXX  is  deleted  at  the 
end  of  the  computation. 

2.  INDEXY  :  temporary  storage  for  data  that  are  eventually  stored  as  AFOS 
product  WRKTPB.  INDEXY  is  deleted  at  the  end  of  the  computation. 
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3.  HMSGPH.01  :  temporary  storage  file  for  graphics  data  that  are  eventually 
stored  as  AFOS  product  NMCGPHEIS.  HMSGPH.01  is  deleted  at  the  end  of 
the  computation. 

D.  Structure  of  the  Software 

RANP  is  the  main  program.  The  program  checks  the  system  clock  to  determine 
which  raob  data  to  process.  After  00Z,  the  program  uses  00Z  data  from  the 
current  date;  likewise,  after  12Z,  12Z  data  is  used.  Sufficient  time  must 
be  allowed  after  these  cutoff  times  for  the  new  raob  data  to  arrive  in  the 
database.  The  database  may  be  checked  prior  to  beginning  the  computation 
by  using  the  global  switch  "C";  see  Part  III,  Section  B.  The  computation 
is  done  for  each  raob  station  listed  in  the  file  STNS1  or  for  the  single 
station  specified  in  the  run  line.  If  the  computation  is  done  for  a  single 
station,  the  date  and  time  of  the  raob  report  are  not  checked  for  currency. 

All  of  the  computations  are  accomplished  by  a  series  of  calls  to  various 
subroutines.  Interpolationsand  extrapolations  of  temperature  and  dewpoint 
in  all  of  the  subroutines  are  done  assuming  a  linear  variation  of  the 
quantity  with  the  logarithm  of  pressure.  At  the  end  of  the  computation, 
the  alert  light  is  turned  on  and  all  temporary  files  are  deleted. 

Sixteen  of  the  subroutines  (indicated  by  *)  are  also  common  to  the  program 
RAN  (Stone,  1983),  but  most  of  them  have  been  changed  or  corrected  and 
are  repeated  here  for  reference. 

The  function  of  the  various  subroutines  are  as  follows: 


PECOS  * 

Reads  the  temperature  portion  of  the  UJ1  raob  specified  in  the  array  JST, 
utilizing  the  AFREAD  subroutine  (Peroutka,  1981). 

TEMPI  * 


This  subroutine  called  by  DECOS  for  decoding  temperature  and  dewpoint. 
INDX1  * 


Computes  lifted  index,  K  index,  and  Showalter  index.  When  surface  pressure 
is  less  than  850mb,  K  and  Showalter  index  cannot  be  computed.  This  will 
be  indicated  by  999  on  the  output. 

BNDX  * 

Determines  pressure  level  PMAX  that  has  the  highest  wet  bulb  potential 
temperature  in  the  lowest  150mb  of  the  sounding.  If  an  identical  maximum 
value  is  found  at  2  levels,  the  lowest  level  (highest  pressure)  is  selected 
for  PMAX.  A  modified  raob  is  created  which  has  its  base  at  level  PMAX  and 
an  additional  significant  level  is  added  at  level  PX  =  400mb,  if  a  signi¬ 
ficant  level  does  not  already  exist  there.  If  the  raob  terminates  below 
level  PX,  but  within  50mb  of  PX,  a  level  PX  is  extrapolated,  so  that  the 
index  Ell  may  still  be  computed. 
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RANN2  * 


The  principal  subroutine,  does  all  the  energy  area  computations  as  the 
parcel  is  raised  from  the  bottom  to  the  top  of  the  sounding.  The  first 
half  of  the  subroutine  raises  a  parcel  along  a  dry  adiabat  from  PMAX  to 
the  lifting  condensation  level  (LCL).  Since  entrainment  is  allowed  during 
the  dry  ascent,  the  LCL  is  usually  slightly  higher  than  it  would  be  if 
there  were  no  entrainment. 

The  second  half  of  the  subroutine  continues  a  moist  ascent  above  the  LCL. 
Entrainment  is  continued  all  the  way  using  the  method  proposed  by  Austin 
(1948). 

A  50mb  step  is  used  for  the  parcel  ascent,  but  if  a  significant  level  is 
present  within  the  next  50mb,  the  step  is  reduced  to  terminate  at  that 
level.  Steps  are  likewise  shortened,  if  the  energy  area  changes  sign, 
or  if  the  LCL  is  reached  during  the  next  50  millibars.  The  50mb  step 
was  selected  because  it  gives  sufficient  accuracy  and  is  economical  in 
computer  time.  On  rare  occasions  when  the  parcel  temperature  and  environ¬ 
mental  temperature  are  very  close  over  a  large  depth  of  the  atmosphere, 
the  50mb  step  may  be  unsatisfactory.  In  such  a  case,  the  computation  is 
restarted  using  a  lOmb  step. 

The  stability  indices  Ell  (Bl)  and  EI2  (B2)  are  computed  after  the  ascent 
has  been  completed.  The  level  of  free  convection  is  also  determined  here. 

The  subroutine  RANN2  is  called  three  times: 

(1)  The  first  call  calculates  the  variable  ETCCL,  which  represents 
the  amount  of  low  level  heating  required  for  a  surface  parcel  to 
reach  the  convective  temperature  and  then  move  dry  adiabatical ly 
to  the  convective  condensation  level,  CCL.  No  entrainment  is 
allowed  in  the  calculation  of  ETCCL. 

(2)  The  second  call  computes  equilibrium  level  with  zero  entrainment. 

(3)  The  third  call  computes  the  energy  indices,  the  lifting  condensation 
level  LCL,  and  the  level  of  free  convection  LFC.  Sixty  percent 
entrainment  is  normally  used  here. 

CCL1  * 


Computes  the  convective  condensation  level  CCL. 

MODRB  * 

Called  immediately  after  CCL1  is  finished  to  modify  the  original  raob  so 
ETCCL  can  be  computed. 

WOBF  SATLFT  TCQNOF  14HR0F  DPTOF  VAPFW  * 

All  thermodynamic  computations  are  done  using  these  six  subroutines  from 
the  National  Severe  Storms  Forecast  Center,  MO.  (Doswell,  et  al.,  1982). 
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ITCVT  * 


Converts  ASCII  characters  to  integer  values.  This  is  a  modification  of 
function  INTCVT  in  AFREAD.LB  (Peroutka,  1981). 

FTCVT  * 

Converts  ASCII  characters  to  floating  point  values.  This  is  a  modification 
of  function  FLTCVT  in  AFREAD.LB  (Peroutka,  1981). 

PULYR  * 

Determines  all  potential  (convective)  unstable  layers  and  computes  lapse 
rate  of  wet  bulb  potential  temperature  in  the  layers  and  amount  of  lifting 
required  to  achieve  saturation  at  the  base  and  top  pressure  of  the  layer. 

TPA 


Outputs  data  for  single  station  analysis  to  INDEXX  file,  which  is  later 
stored  as  AFOS  product  WRKTPA. 

TPB 


Calls  subroutine  PULYR  to  determine  potentially  unstable  layers  with 
results  output  to  INDEXY  file,  for  subsequent  transfer  to  AFOS  product 
WRKTPB. 

FTCV 


This  function  is  used  for  reading  numerical  data  input  by  switches  in  the 
RUN  line.  It  is  a  modification  of  function  FLTCVT  in  AFREAD.LB  (Peroutka, 
1981). 

DECOM 


Reads  the  mandatory  level  raob  data,  US1,  utilizing  the  AFREAD  subroutine 
(Peroutka,  1981). 

IVCK 

This  function,  used  by  DECOS  and  DECOM,  checks  the  date  time  group  of  the 
raob  to  assure  that  the  correct  version  is  being  used. 

WND 


Used  by  DECOM  for  decoding  winds  of  US1  raob  data. 
HEIGHT 


Computes  height  of  an  arbitrary  pressure  by  interpolating  or  extrapolating 
heights  of  mandatory  levels. 
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JREAL 


Rounds  a  floating  point  number  to  an  integer. 
STLOC 


This  uses  the  subroutine  BNSCH  to  search  the  station  directory  file  to 
find  X  and  Y  coordinates  of  each  raob  station  for  plotting  on  a  graphic. 

BNSCH 


Subroutine  for  binary  search  of  data  in  the  station  directory  file. 
(This  program  written  by  Rich  Thomas,  AOD). 

GPT 


Creates  a  graphic  displaying  geographical  distribution  of  Ell  and  EL 
using  subroutines  given  by  MacDonald  (1981). 

ISCR 


Converts  a  positive  or  negative  integer  of  up  to  three  digits  to  ASCII 
characters.  This  is  used  to  convert  Ell  and  EL  for  plotting  on  graphics 

JSCR 


Converts  a  positive  two  digit  integer  to  ASCII  characters.  This  is  used 
to  get  date/time  numbers  for  plotting  on  graphics. 


MTITL 


Makes  date/time  heading  for  graphics  and  converts  number  of  month  to 
three  letter  abbreviation  in  ASCII  characters. 


The  complete  program  would  not  fit  in  memory  without  the  use  of  overlays 

If  the  computation  is  done  for  the  list  of  raob  stations  in  file  STNS1 , 
the  following  overlays  are  used: 


OV0  -  Subroutines  STLOC,  BNSCH 

0V1  -  Subroutines  GPT,  ISCR,  JSCR,  MTITL. 


These  are  used  for  creating  the  graphic  EIS. 

If  the  computation  is  done  for  a  single  raob  station,  the  following 
overlays  are  used: 

0V2  -  Subroutines  TPB,  PULYR 
0V3  -  Subroutine  TPA 


These  are  used  to  output  results  to  AFOS  products  WRKTPB  and  WRKTPA. 
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Ill  Program  Reference 

A.  Preparation 

The  following  AFOS  products  must  be  added  to  the  database  (CCC  is  the 
local  node): 

CCCWRKTPA 

CCCWRKTPB 

CCCWRKTPC 

CCCWRKTPD 

NMCGPHEIS 

The  program  RANP.SV,  its  overlay  file  RANP.OL,  and  the  list  of  raob 
stations  in  file  STNS1  must  be  on  the  main  disk  DP0  or  DP0F  with  a 
link  to  DP0. 

The  file  STNS1  (figure  3)  may  contain  up  to  50  raob  stations  (significant 
level  AFOS  identifiers).  The  list  is  read  using  the  FORMAT  (5A2).  If 
a  list  of  more  than  50  raob  stations  is  needed,  the  parameter  "NRAOB" 
must  be  changed  in  the  main  program  RANP  and  the  subroutines  GPT  and 
STLOC . 

Significant  level  raob  data  for  all  stations  specified  in  STNS1  must 
be  in  the  database.  Correspondi ng  mandatory  level  data  should  also  be 
in  the  database;  if  it  is  missing,  the  U.S.  Standard  Atmosphere  is 
assumed  for  the  computation  of  equilibrium  level  in  feet. 

B.  Initiating  the  Program 

To  run  the  program  at  the  ADM  to  compute  stability  indices  for  the 
list  of  stations  in  file  STNS1,  type: 

RUN: RANP 

A  switch  is  available  for  changing  the  entrainment  rate  from  its  basic 
value  of  60  percent.  For  example,  if  you  wished  to  compare  values  of 
Ell  to  values  of  B1  which  used  100  percent  entrainment  (Stone,  1983), 
you  could  type: 

RUN: RANP  100/E 

We  recommend  that  this  switch  not  be  normally  used. 


A  global  switch  "C"  may  be  used  to  check  the  database  for  the  avail¬ 
ability  of  significant  level  raobs.  If  a  new  raob  is  not  available, 
or  if  the  raob  is  not  in  proper  format,  or  if  it  cannot  be  read  for  any 
reason,  a  message  indicating  the  trouble  is  output  to  AFOS  product 
WRKTPD  (figure  6).  To  check  the  database  at  the  ADM  console,  type: 

RUN: RANP/C 
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This  check  takes  approximately  1%  minutes  for  32  raob  stations. 

A  global  switch  "S"  may  be  used  to  obtain  a  detailed  raob  analysis  for 
a  single  station.  In  this  case,  at  the  ADM,  type: 

RUN:RANP/S  CCCSGLXXX 


The  local  switch  "E"  for  changing  the  entrainment  rate  may  also  be 
used  in  combination  with  the  "S"  switch.  Running  time  for  the  single 
station  computation i s  usually  around  40  to  60  seconds. 

C.  Output 

The  alert  light  is  turned  on  when  the  program  is  finished.  Output  goes 
to  various  AFOS  products  depending  on  the  global  switches  used: 

SWITCH  OUTPUT 

None  WRKTPC  and  EIS 

C  WRKTPD 

S  WRKTPA  and  WRKTPB 

D.  Cautions  or  Restrictions  on  Use 

If  significant  level  raob  data  is  missing,  or  not  in  proper  format,  or 
raob  terminates  below  450mb,  or  a  dewpoint  is  missing  below  the  700mb 
level,  the  computation  is  not  performed  and  a  message  indicating  the 
trouble  will  appear  in  AFOS  product  WRKTPC  or  WRKTPA.  This  situation 
will  be  indicated  on  the  EIS  graphic  by  a  station  circle  with  an  "M" 
inside  it. 

If  mandatory  level  raob  data  are  missing  or  not  in  proper  format,  a 
message  indicating  this  is  printed  on  the  Dasher.  A  U.S.  Standard 
Atmosphere  is  then  assumed  and  the  computation  continues. 

As  the  program  works  its  way  through  the  list  of  raob  stations  in  file 
STNS1,  numbers  appear  on  the  Dasher  indicating  which  raob  data  is 
currently  being  processed,  i.e.  "9"  would  indicate  that  data  for  the 
ninth  station  on  the  list  is  currently  being  computed.  A  mistake  in 
the  significant  level  raob  data,  such  as  a  completely  unrealistic 
temperature  for  some  level,  can  cause  the  program  to  hang  up.  This 
is  a  very  rare  event,  but  if  it  happens,  the  numbers  printed  on  the 
Dasher  indicate  which  raob  is  causing  the  trouble.  The  report  can 
either  be  corrected  or  purged  and  the  program  restarted. 

When  printing  any  of  the  alphanumeric  products  WRKTPA,  B,  C,  or  D 
from  the  ADM  using  the  command  "PRINT:",  an  extraneous  line  of 
printing  frequently  appears  on  the  PPM  copy.  This  problem  will  hope¬ 
fully  be  corrected  by  AFOS  Version  AOD  10.00.  Meanwhile,  a  perfect 
copy  can  be  obtained  by  using  the  command,  "PRINT:WRKTPA" ,  "B",  "C", 
or  "D". 
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E.  Load  Line 

RLDR/P  RANP  DECOS  TEMPI  RANN2  CCL1  MODRB  INDX1  BNDX  UOBF  SATLFT  TCOHOF 
UMROF  DPTOF  VAPFU  DECOM  IVCK  UND  HEIGHT  JREAL  FTCV 
CTPB  PULYR,  TP A,  STLOC  BNSCH,  GPT  ISCR  JSCR  MTITL ] 

OUT  AFREAD.LB  ITCVT  FTCVT  TOP. LB  AG. LB  UTIL. LB  FORT. LB 

F.  Program  Listings: 

See  pages  16  through  55. 

Subroutine  Index  on  page  55. 
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RAOB  INDICES 

FOR 

2/  2/84 

12Z  DP  = 

50. 

EFF  = 

60 

I. 

PX  = 

400. 

ENERGY 

UNITS  :  J/KG  X  10 

EL  8.  TROP  IN 

HNDS  FT 

STN 

P0 

PMAX 

EL (MB)  ! 

EL (FT)  TROP 

Ell 

E 12 

LI 

KI 

SUI 

CCL 

ETCCL  STN 

1 

CAR 

995. 

845. 

845. 

47.  286. 

-146. 

999. 

26. 

8. 

11. 

640. 

111.  CAR 

2 

PUM 

1021 . 

871 . 

871. 

41.  329. 

-228. 

999. 

27. 

-21. 

17. 

495. 

299.  PUM 

3 

ALB 

1017. 

907. 

907. 

32.  358. 

-290. 

999. 

33. 

-24. 

20. 

485. 

332.  ALB 

4 

BUF 

995. 

845. 

845. 

50.  364. 

-217. 

999. 

22. 

-23. 

16. 

633. 

164.  BUF 

5 

DAY 

982. 

832. 

832. 

54.  380. 

-164. 

999. 

17. 

-11 . 

12. 

616. 

127.  DAY 

6 

PIT 

979. 

829. 

829. 

55.  366. 

-207. 

999. 

19. 

-26. 

17. 

554. 

211.  PIT 

7 

CHH 

1023. 

873. 

873. 

41.  307. 

-242. 

999. 

25. 

-48. 

17. 

456. 

317.  CHH 

8 

ACY 

1026. 

876. 

876. 

41.  376. 

-295. 

999. 

29. 

-25. 

20. 

504. 

323.  ACY 

UAL 

NEU 

RAOB  NOT  AVAILABLE 

10 

I  AD 

1016. 

866. 

866. 

44.  372. 

-265. 

999. 

27. 

-18. 

18. 

536. 

293.  I AD 

1 1 

HTS 

991 . 

850. 

850. 

49.  999. 

-199. 

999. 

18. 

-17. 

13. 

576. 

171.  HTS 

12 

HAT 

1028. 

1014. 

1014. 

4.  379. 

-316. 

999. 

25. 

-39. 

22. 

505. 

338.  HAT 

13 

GSO 

993. 

843. 

843. 

52.  365. 

-207. 

999. 

20. 

-15. 

15. 

539. 

212.  GSO 

14 

CHS 

1024. 

1012. 

1012. 

4.  371. 

-279. 

999. 

19. 

-24. 

16. 

558. 

219.  CHS 

15 

BNA 

999. 

849. 

849. 

50.  377. 

-192. 

999. 

16. 

-22. 

13. 

574. 

164.  BNA 

16 

AHN 

994. 

844. 

844. 

52.  359. 

-204. 

999. 

17. 

-29. 

15. 

552. 

184.  AHN 

17 

AYS 

1019. 

1000. 

1000. 

7.  344. 

-264. 

999. 

20. 

-13. 

14. 

545. 

210.  AYS 

18 

BVE 

1021 . 

1000. 

1000. 

4. E  999. 

-180. 

999. 

12. 

5. 

15. 

760. 

62.  BVE 

19 

JAN 

1011 . 

861. 

861. 

44. E  999. 

-228. 

999. 

20. 

-23. 

15. 

490. 

244.  JAN 

20 

CKL 

1006. 

856. 

856. 

46. E  999. 

-213. 

999. 

19. 

-20. 

14. 

570. 

182.  CKL 

21 

AQQ 

1023. 

873. 

873. 

41. E  999. 

-222. 

999. 

18. 

-26. 

14. 

521. 

211.  AQQ 

22 

TBU 

1020. 

929. 

929. 

24. E  999. 

-142. 

999. 

14. 

-4. 

13. 

636. 

130.  TBU 

23 

EYU 

1019. 

869. 

869. 

42. E  999. 

-91 . 

999. 

5. 

7. 

14. 

766. 

60.  EYU 

24 

PBI 

1020. 

1000. 

783. 

69. E  999. 

-105. 

0. 

6. 

-1. 

6. 

715. 

114.  PBI 

25 

SSM 

989. 

839. 

839. 

49.  346. 

-160. 

999. 

21. 

7. 

14. 

637. 

148.  SSM 

26 

FNT 

988. 

904. 

904. 

31.  369. 

-202. 

999. 

19. 

-11 . 

12. 

649. 

130.  FNT 

27 

GRB 

986. 

836. 

836. 

50.  372. 

-184. 

999. 

26. 

-31 . 

16. 

543. 

200.  GRB 

28 

P I A 

987. 

837. 

821 . 

56.  355. 

-117. 

0. 

16. 

5. 

8. 

644. 

92.  P I A 

29 

SLO 

993. 

843. 

843. 

50.  376. 

-138. 

999. 

15. 

-0. 

11. 

598. 

134.  SLO 

30 

UMN 

961 . 

811. 

811 . 

60. E  999. 

-86. 

999. 

14. 

5. 

5. 

644. 

114.  UMN 

31 

LIT 

997. 

847. 

701. 

99. E  999. 

-115. 

-5. 

20. 

-5. 

7. 

522. 

222.  LIT 

32 

LCH 

1020. 

897. 

897. 

33. E  999. 

-133. 

999. 

14. 

19. 

1 1 . 

582. 

205.  LCH 

Figure  1.  Example  of  WRKTPC 
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PUMSGLCAR 

PUMSGLPUM 

ALBSGLALB 

BUFSGLBUF 

CLESGLDAY 

P ITSGLP IT 

BOSSGLCHH 

PHLSGLACY 

UBCSGLUAL 

UBCSGLIAD 

CRUSGLHTS 

RDUSGLHAT 

RDUSGLGSO 

CAESGLCHS 

MEMSGLBNA 

ATLSGLAHN 

ATLSGLAYS 

NEUSGLBVE 

JANSGLJAN 

BHMSGLCKL 

BHMSGLAQQ 

MI  ASGLTBU 

MIASGLEYLJ 

MIASGLPB I 

ARBSGLSSM 

ARBSGLFNT 

MKESGLGRB 

CHISGLPIA 

CH ISGLSLO 

STLSGLUMN 

L ITSGLL IT 

NEUSGLLCH 


Figure  2.  Example  of  EIS  graphic. 


Figure  3.  Example 
of  file  STNS1 . 
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RAOB  ANALYSIS  FOR  PBI  2/  2/84  12Z  UNITS  :  J/KG  X  10 

ASSUMED  EFF  =  60.  PERCENT  ENTRAINMENT  PER  500MB  ASCENT,  FOR  Ell,  EI2  8,  EL60 
ASSUMED  EFF  =  0.  PERCENT  ENTRAINMENT  PER  500MB  ASCENT,  FOR  EL 


P0  =  1020.  PTOP  =  100.  PMAX  (MAX  INSTABILITY)  =  1000.  PX  =>  400. 

EL  =  783.  MB  (  69. E  HND  FT)  LCL  =  898.  LFC  =  865. 

BASED  ON  PARCEL  MVG  FM  LVL  -PMAX- 


E 12  = 

0. 

ENERGY  PMAX  TO  EL60 

Ell 

= 

-105. 

ENERGY  PMAX  TO  PX 

EI2P  = 

3. 

POSITIVE  PART 

E I  IP 

= 

3. 

POSITIVE 

PART 

EI2N  = 

-2. 

NEGATIVE  PART 

E I  IN 

= 

-108. 

NEGATIVE 

PART 

PI 

P2 

ENERGY  GAINED 

(LOST) 

IN 

LAYER 

1000. 

865. 

-2. 

865. 

784. 

3. 

784. 

100. 

-814. 

EX  - 

-106. 

LI  - 

6.  K I 

=  -1.  SUI  = 

6. 

CCL  = 

715.  ETCCL  =  114.  CONV 

TEMP  =  : 

34. 

7  (  94. 

5F  )  UAVG 

=  7.73  G/KG 

DEEPEST  POT.  UNSTABLE  LYR  :  1000.  -  789.  MB,  TULAPSE  =  3.6  SEE  URKTPB 


Figure  4.  Example  of  WRKTPA 


POTENTIAL  (CONVECTIVE)  UNSTABLE  LAYERS  FOR  PBI  2/  2/84  12Z 


PI 

P2 

429. 

392. 

615. 

453. 

1000. 

789. 

SIGNIF 

ICANT  LEVELS 

P 

T 

100. 

-70.3 

108. 

-72.7 

126. 

-65.3 

259. 

-48.3 

300. 

-39.7 

349. 

-32.5 

360. 

-32.9 

392. 

-28.7 

429. 

-22.9 

453. 

-20.1 

500. 

-14.9 

615. 

-4.3 

621 . 

-4.7 

630. 

-4.  1 

729. 

6.4 

775. 

5.6 

789. 

0.6 

805. 

2.4 

850. 

5.8 

1000. 

17.4 

1015. 

15.8 

1020. 

12.2 

Fi gure 

DP 

TULAPSE 

37. 

3.3 

162. 

0.2 

211. 

3.6 

TD 

TU 

-100.3 

30.7 

-102.7 

28.7 

-95.3 

28.2 

-78.3 

18.2 

-69.7 

17.8 

-62.5 

16.7 

-62.9 

15.6 

-58.7 

15.0 

-26.0 

16.2 

-25.  1 

15.8 

-16.3 

16.  1 

-5.4 

16.  1 

-13.7 

13.7 

-23.  1 

12.2 

-23.6 

1 1.6 

-24.4 

9.  1 

-29.4 

5.8 

2.0 

11.9 

5.5 

12.7 

10.4 

13.3 

11.1 

12.4 

10.6 

10.4 

Example  of  WRKTPB 


DPI 

DP2 

22. 

160 

11. 

36 

100. 

300 

BULB  POTENTIAL  TEMP) 


-14- 


SGL  REPORTS  MISSING  OR  INCORRECT  FORMAT,  2/  2/84 
UAL  NEU  RAOB  NOT  AVAILABLE 


Figure  6.  Example  of  WRKTPD 


12Z 
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n  n 


C  RANP.FR 

C  THIS  VERSION  UORKS  WITH  C  „E  AND  S  SWITCH. 

C  "RANP "  COMPUTES  STABILITY  INDICES  FOR  SET  OF  RAOB  STATIONS, 

C  SPECIFIED  IN  FILE:  "STNS1"  WITH 
C  OUTPUT  TO  AFOS  PRODUCT  "URKTPC"  AND  "NMCGPHE IS " . 

C 

C  GLOBAL  SWITCH  "C"  DOES  CHECK  OF  DATABASE  ONLY;  "SGL"  REPORTS  THAT 
C  CANNOT  BE  READ  ARE  LISTED  IN  "WRKTPD". 

C 

C  GLOBAL  SWITCH  "S"  MAY  BE  USED  FOR  A  SINGLE  STATION  COMPUTATION  WITH 
C  OUTPUT  TO  AFOS  PRODUCTS  " WRKTPA "  &  "WRKTPB " . 

C 

C  ZERO  PERCENT  ENTRAINMENT  ALWAYS  USED  FOR  EQUILIBRIUM  LEVEL. 

C  SIXTY  PERCENT  ENTRAINMENT  FOR  ALL  OTHER  COMPUTATIONS,  BUT  MAY  BE 
C  CHANGED  WITH  LOCAL  SWITCH  "E". 


C 

C 

C 


FOLLOWING  PARAMETER  MUST  EQUAL  OR  EXCEED  NUMBER  OF  RAOB  STNS  TO  BE 
PROCESSED,  AND  MUST  AGREE  WITH  -NRAOB-  PARAMETER  IN  SUBROUTINES  -GPT- 
AND  ' STLOC' . 

PARAMETER  NRAOB=50 


ISTCNRAOB, 2) 


COMMON/S/JST (5) , KDATE (3) , IHOUR, JNO, JJNO, P (0 : 50) , TS C0 : 50) , TSD (0 : 50) 
COMMON/T/RLCL, RLFC, EL, B2, B2P,  B2N, I ALL, B 1 ,  B IP, B IN, EX 
COMMON/CCL/PCCL, ETCCL, TS0, TSD0, L, TSCCL, TCCL, TDCCL, WAVG 
COMMON/G/PP (0 : 20) , ET(20) , TU(0 : 50) , DP, EFF,  KMOD, KK 
COMMON/GG/NJ, PPB ( 15) , PPT ( 15) , DELPP ( 15) , DTWDP ( 15) , DPB ( 15) , DPT( 15) , 

1  PTMAX, PBMAX, TWL APSE , DMAX  ;  FOR  PULYR  SUBROUTINE 
COMMON/TT/PT ( 0 : 50 ) , TST ( 0 : 50 ) ,  TSDT (0:50) 

COMMON/V/JNOM,  PX 
COMMON/H/IHDR1 ( 1 1) ,KEY(5) 

COMMON/ZZZ/ZZ (0 : 12) 

DIMENSION  IXX(NRAOB) , IYY(NRAOB) , JB(NRAOB) , JEL(NRAOB) 

DIMENSION  H (0 : 12) , T(0 : 12),TD(0: 12),D(0: 12) , S (0 : 12) 

INTEGER  SW(2) , DAT ( 10) 

EXTERNAL  OV0, OV1 , 0V2, 0V3 
DATA  IHDR1/"  RKTPC000 " 

DATA  KEY/ "URKTPC"/ 

"ZZ"  HEIGHT  OF  STANDARD  PRESSURE  SURFACES,  U.  S.  STANDARD  ATMOSPHERE 
DATA  ZZ/0., 111., 1457., 30 12., 5574., 7 185., 9 164., 10363., 11784., 13608., 
1  16180. ,999. ,0./ 

IFD= 10  ;  OUTPUT  DEVICE  FOR  ERROR  MESSAGES  FROM  DECOM 
IFC=20  ;  OUTPUT  DEVICE  FOR  ERROR  MSGS  FM  DECOS,  BNDX, 

CNVM=. 032808399  ;  CONVERSION  FACTOR,  M  TO  FT  X  10-2 

CALL  KF ILL  (KEY, IER) 

IHDR1 (1) =KEY( 1 ) 


;  OV0  &  OV1  -  NO  SWITCH,  0V2  8.  0V3 
177777K, 177777K, "70 " , 142600K, 6412K/ 


-  S  SWITCH 


INDX1  SUBROUTINES 


IHDR1 (2) =KEY(2) 
IEND= 10 1603K 
DP=50 . 

I  ALL= 1 
PX=400 . 


;  ENDING  FOR  AFOS  PRODUCT 

;  50  MB  STEP 

;  I ALL=2  TO  PRINT  EVERY  LVL  IN  RANN2  SUBROUTINE 
;  CUT-OFF  PRESSURE  FOR  Ell  INDEX 
N=0  ;  COUNTER  FOR  NUMBER  OF  RAOB  STATIONS 

CALL  FCOM  ( IC, IER) 

CALL  COMCM  ( IC, DAT, 1 1 , SW, IER)  ;  READING:  RUN : RANP 
ICK=0 

IF  ( ISWSET (SW, "C " ) )  ICK= 1  ; 

IF  ( ISWSET (SW, "S " ) )  ICK=2  ; 

IF  (ICK.EQ.0)  GO  TO  45  ; 

IF  (ICK.EQ.2)  GO  TO  50 
IHDR 1 (5) = "D0 " 


ICK= 1  DENOTES  DATABASE  CHECK  ONLY 

ICK=2  DENOTES  SINGLE  STATION  COMPUTATION 

ICK=0  DENOTES  FULL  COMPUTATION  FOR  LIST  OF  STATIONS 
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GO  TO  41 

45  CALL  CFILU( "HMSGPH.01 ",2, IER)  ;  CREATING  GRAPHIC  FILE 

IF  (IER.NE.l)  URITE  (10,35)  IER 

35  FORMAT  (1H  , " IER  -  \I4, "  CFILU,  PROGRAM  RANP,  STATEMENT  35") 

GO  TO  49 

C  SINGLE  STATION  COMPUTATION 

50  IHDR 1 (5) = "A0"  ;  DENOTES  INDEXX  TO  STORE  IN  URKTPA 

DO  51  1  =  1,  10 

51  DAT ( I ) =0 

CALL  COMCMC IC, DAT, 1 1 , SU, IER)  ;  READING  CCCSGLXXX 
DO  52  1=1,5 

52  JST ( I ) =DAT ( I ) 

JER= 1  ;  INDICATOR  THAT  SINGLE  STATION  COMPUTATION  COMPLETED  OK 

C 

49  DO  43  1  =  1,  10 

43  DAT ( I ) =0 

CALL  COMCM  ( IC, DAT, 1 1 , SU, IER)  ;  READING  ENTRAINMENT  RATE 

IF  ( ISUSETCSU, "E" ) )  GO  TO  40  ;  SPECIAL  EFF  HAS  BEEN  READ 

EFF0=60 .  ;  NORMAL  ENTRAINMENT  RATE  IN  PERCENT 

GO  TO  41 

40  EFF0=FTCV(DAT, $44) 

URITE  (10,42)  EFF0 

42  FORMAT  (1H  ,  "EFF0  =  \F5.0) 

GO  TO  41 

44  CALL  FORKE  ( "RANP ", "EFF0 ", IER) 

CALL  KLOSE ( IC, IER) 

STOP 

41  CONTINUE 

CALL  KLOSE  ( IC, IER) 

CALL  FOPEN  (20, " INDEXX" , 300) 

CALL  FGTIME  ( IHR, IMIN, ISEC)  ;  GET  TIME 

CALL  DATE  (KDATE, IER)  ;  (MO,DY,YR)  GET  DATE 

KDATE (3) =KDATE (3) - 1900  ;  MAKING  2  DIGIT  YEAR 

KDAT =KDATE (2)  ;  SAVE  ORIGINAL  KDATE (2)  FOR  SINGLE  STN  COMPUTATION 

IHOUR=0 

KTIME=IHR*100+IMIN 

C 

IF  (KTIME.GT. 1200)  IH0UR=12  ;  DOES  LATEST  TIME 
IM= ICK+1 

GO  TO  (20,53,58), IM 

58  URITE  (20,59)  ;  LEAVING  ROOM  FOR  HEADER  AT  BGNG  OF  INDEXX  FILE 

59  FORMAT  (12X, "  ") 

KDATE (2) =0  ;  SIGNIFIES  NOT  TO  DO  DATE/TIME  CHECK 

GO  TO  54 

53  URITE  (20,29)  (KDATE( I), 1=1,3), IHOUR 

29  FORMAT  (12X,  11  SGL  REPORTS  MISSING  OR  INCORRECT  FORMAT,  ", 

1  12, 12, 12, 2X, 12, "Z") 

GO  TO  31 

20  URITE  (20,21)  (KDATE(I), 1=1,3), IHOUR, DP, EFF0,PX 

21  FORMAT  ( 12X, "  RAOB  INDICES  FOR  " , 12, "/" , 12, , 12, 

1  2X, 12, "Z",3X, "DP  =  ",F4.0,3X, "EFF  =  ",F5.0,3X, "PX  =  ",F5.0 

2  /"<  15X  12>",  "  ENERGY  UNITS  :  J/KG  X  10",5X,  "EL  8.  TROP  IN  HNDS  FT") 
URITE  (20,23) 

23  FORMAT  ( "< 15X 12> " , 3X, "STN",3X, "P0",2X, "PMAX", IX, "EL (MB) ",  IX, "EL (FT) “ 

1  , IX, " TROP " , 3X, "EI1",3X, "EI2",3X, "LI",3X, "KI",2X, "SUI",2X,  "CCL",  IX, 

2  "ETCCL", IX, "STN") 

URITE  (20,27) 

27  FORMAT  ( "<  15X  12> " )  ;  BLANK  LINE 

31  CALL  OPEN  (22, "STNS1 ",  1, IER)  ;  FILE  STNS  CONTAINS  RAOB  ID'S 

IF  (IER.NE.l)  STOP  OPEN  ERROR 
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5  READ  (22,3,END=8)  ( JST( I) , 1-1,5) 

3  FORMAT  (5A2) 

N=N+1 

CALL  TYPED (N)  ;  TYPES  N  ON  DASHER  TO  MONITOR  PROGRESS 

IF  (N . EQ . 20 . OR . N . EQ . 40 . OR . N . EQ . 60 . OR . N . EQ . 80)  URITE  C 10,48)  ;  NXT  LINE 
48  FORMAT  ( 1H  ) 

IST(N, D-JSTC4)  ;  MAKING  STATION  ID  FOR  PLOTTING 
IST(N,2)-JST(5) 

54  CALL  DECOS  ( JST,KDATE(2) , IHOUR, JNO, P, TS, TSD, IFC, $26) 

IF  ( ICK.EQ. 1)  GO  TO  5  ;  SGL  READ  OK 

DO  76  1=0, JNO 

IF  (TSD(I) .NE.999.)  GO  TO  76 
IF  CPC  I) .GE.700.)  GO  TO  7 

TSD ( I ) =TS ( I ) -30 .  ;  IF  DEUPT  MISG  ABV  700MB,  ASSUME  DRY 

76  CONTINUE 

GO  TO  6 

7  URITE  (20,10)  N, (JST(J) , J-4,5) ,P( I) 

10  FORMAT  ( "< 15>< 12> " , 12, IX, 2A2, "  DEUPOINT  MISSING  AT  P  =  ”,F5.0) 

GO  TO  26 

6  KMOD=0  ;  FOR  ETCCL  CALCULATION 

CALL  CCL 1  ( IFC, $26) 

CALL  MODRB  ;  MODIFIES  RAOB  FOR  ETCCL  COMPUTATION 

CALL  RANN2  (PT, TST, TSDT, JNOM, PX)  ;  CALLED  FOR  ETCCL  ONLY,  JNOM  FM  MODRB 
CALL  INDX1  (RL I , RK I , RUI , $26, IFC) 

CALL  BNDX  (IFC, $26)  ;  MODIFY  RAOB  FOR  MAX  INSTABILITY 

EFF=0.  ;  ZERO  ENTRAINMENT  FOR  EQUILIBRIUM  LVL 
KM0D=2  ;  FOR  NORMAL  COMPUTATION  UITH  RANN2 

CALL  RANN2  (PT, TST, TSDT, JNOM, PX)  ;  COMPUTE  EL  LVL,  JNOM  FROM  BNDX 
EL0=EL  ;  SAVE  EL  UITH  ZERO  ENTRAINMENT  RATE 
EFF  =EFF0  ;  RESET  ENTRAINMENT  RATE  FOR  ALL  OTHER  COMPUTATIONS 

JEFF  =JREAL (EFF) 

CALL  RANN2  (PT, TST, TSDT, JNOM, PX)  ;  COMPUTE  STABILITY  INDICES 
EL=EL0  ;  USE  EL  UITH  ZERO  ENTRAINMENT 
C. 

C  THIS  SECTION  USES  MANDATORY  LVLS  TO  GET  "EL"  AND  "TROP"  IN  FEET. 

JST (2) =JST (2) - "  5"+"  M"  ;  MAKING  ID  FOR  MANDATORY  LVLS 
JST (3) = "AN " 

IDECOM= 1  ;  INDICATOR  THAT  MANDATORY  LVLS  USED  FOR  EL  AND  TROP 

KDATE (2) =KDAT  ;  RESETTING  KDATE (2) 

CALL  DECOM  ( JST, KDATE (2) , IHOUR, H, T, TD, D, S, $9, IFD, PTROP)  ;  READ  MANDATORY  LVLS 
17  IF  (EL.NE.0.)  GO  TO  14 

EL  1=999.  ;  EQUILIBRIUM  LEVEL  NOT  COMPUTED 

GO  TO  15 

14  CONTINUE 

CALL  HEIGHT  (H, EL, EL  1 , $9)  ;  CONVERT  EL  TO  METERS 
EL  1 =EL 1*CNVM  ;  CONVERT  M  TO  FT  X  10-2 

15  CONTINUE 

IF  (PTROP. NE.999.)  GO  TO  13 
TR0P=999 .  ;  TROP  NOT  OBSERVED 

GO  TO  16 

13  CALL  HEIGHT  (H, PTROP, TROP, $30)  ;  GET  TROP  IN  METERS 

TROP  =TROP*CNVM  ;  CONVERT  M  TO  FT  X  10-2 

GO  TO  16 

30  URITE  (10,33)  (JST( I) , 1=1,5) , PTROP 

33  FORMAT  (1H  ,5A2,"  PTROP  =  \F8.0,"  ERROR  RANP,  STATEMENT  33") 

TROP=999 . 

GO  TO  16 
C 

C  CANNOT  USE  MANDATORY  LVLS  (NOT  AVBL,  TOO  LARGE  EXTRAPOLATION,  ETC.) 

9  IDECQM=0  ;  MANDATORY  LVLS  NOT  USED 
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DO  11  1=0,12 

11  H(I) =22(1)  ;  SUBSTITUTE  U.  S.  STANDARD  ATMOSPHERE 

PTR0P=999. 

GO  TO  17 
C 

C  OUTPUT  FOLLOUS 
16  CONTINUE 

IF  (ICK.EQ.2)  GO  TO  56 
JB (N) =JREAL (B 1 ) 

JEL  CN) =JREAL (EL  1 ) 

IF  CIDECOM.EQ. 1)  GO  TO  12  ;  MANDATORY  LEVELS  USED 

URITE  (20,28)  N, ( JST ( I ) , I =4,5) , P (0) , PT(0) , EL, ELI , TROP, B 1 ,B2,RL I ,RK I 
1  ,RUI,PCCL,ETCCL, (JST( I), 1=4,5)  ;  NO  MANDATORY  LVLS  USED 

28  FORMAT  ( "< 15X 12> " , 12, 1X,2A2,F5.0,3F6.0, "E",F5.0, 1X,2F6.0,3F5.0, 

1  2F5 .0, IX, 2A2) 

GO  TO  5 

12  URITE  (20,22)  N, ( JST( I ) , I =4, 5) , P (0) , PT(0) , EL, EL  1 , TROP, B 1 , B2, RL I , RK I 

1  , RUI , PCCL, ETCCL, ( JST ( I ) , I =4, 5)  ;  MANDATORY  LVLS  USED .. TROP  8.  EL 

22  FORMAT  ( "< 15X 12>",  12, IX, 2A2, F5 . 0, 3F6 . 0, 1X,F5.0, IX, 2F6 . 0, 3F5 . 0, 

1  2F5 .0, IX, 2A2) 

GO  TO  5 

26  CONTINUE 

JER=0  ,-  INDICATES  SINGLE  STATION  COMPUTATION  NOT  COMPLETED 
IF  (ICK.EQ.2)  GO  TO  55 

C  INSERT  DUMMY  VALUES  FOR  STAB  INDICES  FOR  PLOT  HERE  I 
JB (N) =999 
JEL (N) =999 
GO  TO  5 

8  URITE  (10,48)  ;  NEXT  LINE 

CALL  CLOSE  (22,  IER) 

IF  (IER.NE.l)  STOP  CLOSE  ERROR 
GO  TO  55 
C 

C  OUTPUT  FOR  SINGLE  STATION  ANALYSIS 
56  CALL  GCHN  (ICHN, IER) 

IF  (IER.NE.l)  TYPE  "GCHN  ERROR  FOR  OVERLAY  0V2  8<  3,  IER  =  ",IER 

CALL  OVOPN  ( ICHN, "RANP.OL", IER)  ;  OPEN  RANP.OL 

IF  (IER.NE.l)  TYPE  "RANP.OL  OPENING  ERROR,  IER  =  ",IER 

CALL  OVLOD  ( ICHN, 0V2, - 1 , IER)  ;  LOAD  0V2 

IF  (IER.NE.l)  TYPE  "0V2  LOADING  ERROR,  IER  =  11 ,  IER 

CALL  FOPEN  (2 1 , " INDEXY" , 300) 

CALL  TPB  ;  COMP.  OF  POT  UNSTBL  LYRS  AND  OUTPUT  TO  CHANNEL  21 
CALL  CLOSE  (21, IER) 

CALL  OVLOD  ( ICHN, 0V3, - 1 , IER)  ;  LOAD  0V3 
IF  (IER.NE.l)  TYPE  "0V3  LOADING  ERROR,  IER  =  ",IER 

CALL  TP A (JEFF, EL  1 , RL I , RK I , RUI , IDECOM)  ;  OUTPUT  FOR  SNGL  STN  RAOB  ANALYSIS 

CALL  KLOSE  (ICHN, IER) 

IF  (IER.NE.l)  TYPE  "KLOSE  ERROR  FOR  ICHN,  IER  =  ", IER 
C 
C 

55  CALL  CLOSE  (20,  IER) 

IF  (IER.NE.l)  TYPE  "CHANNEL  20  CLOSE  ERROR,  IER  =  ",IER 
C 

C  INSERT  HEADING  AND  ENDING  ON  INDEXX 

CALL  GCHN  (ICHN,  IER)  ;  GET  RDOS  CHANNEL 
CALL  OPENN  ( ICHN, " INDEXX" , 0, IER) 

CALL  URS  (ICHN,  IHDR1,22, IER)  ;  HEADER  INSERTION 
CALL  KLOSE  ( ICHN, IER) 

CALL  GCHN  (ICHN, IER)  ;  GET  RDOS  CHANNEL 

CALL  OPENA  ( ICHN, " INDEXX" , 0, IER)  ;  OPEN  FOR  APPENDING 
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CALL  URS  (ICHN, IEND,2, IER)  ;  ENDING  FOR  AFOS  PRODUCT 
CALL  KLOSE  (ICHN, IER) 

CALL  FSTORE  (" INDEXX" , 0, IER)  ;  STORE  INTO  URKTPA, C,  OR  D 
GO  TO  (57,39,66), IM  ;  IM-ICK+1 
C 

C  INSERT  HEADING  AND  ENDING  ON  INDEXY 

66  IF  ( JER.EQ.0)  GO  TO  63 
IHDR1 (5) ="B0" 

CALL  GCHN  (ICHN, IER)  ;  GET  RDOS  CHANNEL 
CALL  OPENN  ( ICHN, " INDEXY" , 0, IER) 

CALL  URS  (ICHN, IHDR1,22, IER)  ;  HEADER  INSERTION 
CALL  KLOSE  ( ICHN, IER) 

CALL  GCHN  (ICHN,  IER)  ;  GET  RDOS  CHANNEL 
CALL  OPENA  ( ICHN, " INDEXY" , 0, IER)  ;  OPEN  FOR  APPENDING 
CALL  URS  (ICHN, IEND,2,  IER)  ;  ENDING  FOR  AFOS  PRODUCT 
CALL  KLOSE  ( ICHN, IER) 

CALL  FSTORE  (" INDEXY" , 0, IER)  ;  STORE  INTO  URKTPB 
CALL  FORKP  ( "RANP ", "URKTPA, URKTPB ", IER) 

GO  TO  46 
C 

C  CREATE  GRAPHIC  EIS 
57  CALL  GCHN  ( ICHN, IER) 

IF  (IER.NE.l)  TYPE  "GCHN  ERROR  FOR  OVERLAY  OV0  &  1,  IER  =  ",IER 

CALL  OVOPN  ( ICHN, "RANP. OL", IER)  ;  OPEN  RANP. OL 

IF  (IER.NE.l)  TYPE  "RANP . OL  OPENING  ERROR,  IER  =  ",IER 

CALL  OVLOD  ( ICHN, OV0, - 1 , IER)  ;  LOAD  OV0 

IF  (IER.NE.l)  TYPE  "OV0  LOADING  ERROR,  IER  =  ",IER 

CALL  STLOC(N, IXX, IYY, 1ST) 

CALL  OVLOD  ( ICHN, OV1 ,- 1 , IER)  ;  LOAD  OV1 

IF  (IER.NE.l)  TYPE  "OV1  LOADING  ERROR,  IER  =  ",IER 

CALL  GPT(N, IXX, IYY, JB,JEL, 1ST, IHOUR,KDATE, JEFF)  ;  CREATE  AFOS  GRAPHIC 
CALL  KLOSE  ( ICHN, IER) 

IF  (IER.NE.l)  TYPE  "KLOSE  ICHN,  IER  =  ",IER 

CALL  FORKP  ( "RANP " , "URKTPC  &  EIS",  IER)  ;  TURN  ON  ALERT  LIGHT 
GO  TO  46 

39  CALL  FORKP  ( "RANP ", "URKTPD ", IER) 

63  DO  68  1=1,1000 

68  TIMEUASTE=l./2.  ;  DELAY  FOR  CALL  TO  DFILU 

46  DO  61  1=1, 1000 

CALL  DFILU  ( " INDEXX" , IER)  ;  DELETE  INDEXX  FILE 
IF  (IER.EQ. 1)  GO  TO  62 

61  CONTINUE 

IF  (IER.NE.l)  TYPE  "INDEXX  FILE  NOT  DELETED,  IER  =  ", IER 

62  GOTO  (32,38,60), IM  ;  IM=ICK+1 

60  IF  (JER.EQ.  1)  GO  TO  67 

CALL  FORKP  ( "RANP ", "URKTPA ", IER) 

STOP 

67  DO  64  1=1,1000 

CALL  DFILU  (" INDEXY" , IER)  ;  DELETE  INDEXY  FILE 
IF  (IER.EQ.  1)  GO  TO  65 

64  CONTINUE 

IF  (IER.NE.l)  TYPE  "INDEXY  FILE  NOT  DELETED,  IER  =  ",IER 

65  STOP 

32  DO  37  1  =  1,  1000 

CALL  DFILU  ( "HMSGPH . 0 1 " , IER)  ;  DELETE  GRAPHIC  FILE 

IF  ( IER.EQ. 1)  GO  TO  38  ;  THIS  LOOP  IS  NECESSARY,  FOR  SLOU  CLOSING 

37  CONTINUE 

IF  (IER.NE.l)  URITE  (10,36)  IER 

36  FORMAT  (1H  , "IER  =  ",I4, "  HMSGPH. 01  NOT  DELETED  -  RANP,  STATEMENT  36") 

38  STOP 
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n  n 


END 


* 


* 

SUBROUTINE  DECOS  < JST, IDATE, IHOUR, JNO, P, TS, TSD, IFC, Q) 

C  DECODES  RAOB  S IGN IF ICANT  LEVELS  UP  TO  100MB 
C  JST. . . AFOS  IDENTIFIER 

C  IDATE/IHOUR  IS  THE  DATE/HOUR  UANTED  FOR  DECODING. 

C  I DATE =0  MEANS  DATE  AND  HOUR  NOT  TO  BE  TESTED. 

C  JNO ...  NO .  OF  SIGNIFICANT  LEVELS  DECODED. 

C  P. . .PRESSURE,  TS. . .TEMPERATURE,  TSD . . . DEUPO INT. 

C  IFC... OUTPUT  DEVICE,  Q... ABNORMAL  ERROR  RETURN  STATEMENT  NUMBER. 

DIMENSION  JST(5) ,P (0:50), TS (0:50) , TSD (0:50) 

DIMENSION  IOUT (40) 

INTEGER  D 

CALL  AFREAD  (1, JST, $100) 

CALL  AFREAD  (2,  IOUT, $50, $125) 

C  TEST  FOR  NEU  RAOB  CODE  FORMAT 

15  IF  ( IOUT (4)  . EQ .  "TT" .  AND .  IOUT (5)  . EQ .  "BB 11 )  GO  TO  9 

GO  TO  10  ;  OLD  RAOB  CODE 

9  IF  ( I0UT(6) .EQ. "  5 " . OR . I0UT(6) . EQ . "  6 " . OR . I0UT(6) . EQ . " 

1  OR. IOUT (6) .EQ. "  8")  GO  TO  11 

K=-5  ;  DOUBLE  SPACE  AFTER  TTBB 

Kl— 3 
K2=-2 
GO  TO  12 

11  K=-6  ;  SINGLE  SPACE  AFTER  TTBB 

K 1  =-3 

K2=-2 
GO  TO  12 

C  OLD  RAOB  CODE  FORMAT 

10  K=0 

IF  (I0UT(6) .EQ. "  U " . AND . I OUT ( ? ) . EQ . " J 1 " )  K=4 

Kl=K/2 

K2=K  1 

IF  (I0UT(9+K1) .EQ. "  5" .OR. I0UT(9+K1) .EQ. "  6" .OR. I0UT(9+K1) .EQ. "  7". 

1  OR. I0UT(9+K1) .EQ. "  8")  GO  TO  12  ;  TESTING  FOR  DOUBLE  SPACE  AFTER  TTBB 

K=K- 1 

12  JDATE= ITCVT ( 18+K, 2, $900) -50 
JHOUR= ITCVT (20+K, 2, $900) 

IF  (IDATE.EQ.0)  GO  TO  13 
I VCHECK  =  I VCK ( I DATE , IHOUR, JDATE, JHOUR) 

GO  TO  (13, 14, 133, 135), IVCHECK 
14  CALL  PRVRF(IER) 

IF  (IER.NE.  1)  GO  TO  135 
CALL  AFREAD  (3, JST, $102) 

CALL  AFREAD  (2, IOUT, $50, $125)  ;  READ  1ST  LINE  OF  PRVS  VERSION 

GO  TO  15 

TEST  FOR  MISSING  RAOB  10142  ETC. 

13  1 1 A= ITCVT (30+K, 4, $900) 

1 IB= ITCVT (34+K, 1,$900) 

II IA=ITCVT(36+K,3,$900) 

IF  (IIA.EQ. 5151. AND. I  IB . EQ . 5 . AND . IIIA.EQ. 101)  GO  TO  126 
C 

JNO=0 

DO  1  1=0,2 
11=6*1 
12=11+11 
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1 1  =  I TC VT ( 30+K+ 12,2, $900 ) 

IJJ=I*11 

IF  (IJJ.NE.II)  GO  TO  127  ;  TEST  FOR  IMPROPER  FORMAT 

IF  ( IOUTC 17+K1+I 1) .EQ. "/V" .OR. I OUT ( 17+K1+I 1) .EQ. "/  ")  GO  TO  1  ;  SIG  LVL  PRS  MISG 
P ( JNO ) =FTCVT ( 32+K+ 12,3, $90 1 ) 

IF  (PCJNO) .LT. 100.)  P ( JNO) =P (JNO) +1000 . 

TS ( JNO ) =FTC VT ( 36+K+ I 2 , 3 , $90 1 ) 

IF  CIOUTC20+K1  +  I1)  .EQ.  "//"  .OR.  IOUTC20+K2+1 1 )  .EQ.  "/  ")  GO  TO  2  ;  DEUPT  MISG 

TSD ( JNO ) =FTC VT ( 39+K+ 12, 2, $901) 

GO  TO  3 

2  TSDC JNO) =999. 

3  CALL  TEMPI CTSC JNO), TSDCJNO))  ;  TEMPERATURE  DECODER 
JNO=JNO+l 

1  CONTINUE 

C  FIRST  LINE  OF  RAOB  IS  FINISHED  HERE 
C  STATEMENT  4  STARTS  2ND  AND  SUBSEQUENT  LINES 
JNO=JNO- 1 
I  JK=22 

4  CALL  AFREAD  (2, IOUT, $50, $125) 

DO  5  1=0,4 

1 1 =6*1 
12=11+1 1 
I JK= I JK+1 1 

IF  (IJK.EQ.110)  I JK  =  11 
I JK 1 =12+1 

IF  ( IOUTC 1 1+2) .EQ. "//")  GO  TO  5  ;  SIG  LVL  PRESSURE  MISG 

15 15= ITCVT ( 12+1, 3, $900) 

IF  ( 1515. EQ. 515)  GO  TO  53  ;  TEST  FOR  51515  101XX  GROUP  ENDING  MSG 

J I = ITCVT ( I JK 1 , 2, $900) 

IF  (IJK.NE.JI)  GO  TO  128  ;  TEST  FOR  IMPROPER  FORMAT 

IF  CJNO.EQ.50)  GO  TO  51 

JNO=JNO+l 

PCJNO) =FTCVT( 12+3, 3, $901) 

IF  CPCJNO) .LT. 100.)  PCJNO) =P (JNO) +1000 . 

TS ( JNO) =FTCVT ( 12+7, 3, $90 1 ) 

10= IOUT ( 1 1+6) 

IF  (IO.EQ."/  ".OR. 10. EQ. "/=")  GO  TO  6 
TSD (JNO) =FTC VT (12+10,2, $90 1 ) 

GO  TO  7 

6  TSD  C JNO) =999 . 

7  CALL  TEMPI CTSCJNO) ,TSD(JNO) ) 

IF  CIO.EQ. "/=" .OR. 1 0 . EQ . " 0  = " . OR . 1 0 . EQ . " 1  = " . OR . 1 0 . EQ . "2  =  " .OR. IO.EQ. 

1  "3= ".OR. IO.EQ. "4= ".OR. IO.EQ. "5= " .OR. IO.EQ. "6-" .OR. IO.EQ. "7= ".OR. 10. 

2  EQ. "8=".0R. IO.EQ. "9=")  GO  TO  53  ;  TEMPERATURES  FINISHED 

5  CONTINUE 

GO  TO  4  ;  RETURNS  TO  4  TO  DO  3RD  AND  SUBSEQUENT  LINES 

53  CONTINUE 

C  IF  UIND  DATA  REQUIRED,  READ  IT  HERE... 

RETURN 

51  URITE  C IFC, 52)  ( JSTC I) , I =4,5) ,P( JNO) 

52  FORMAT  ( "< 15X 12>\  1X,2A2, IX, "51  SIGNIFICANT  LEVELS  HAVE  BEEN  DECOD 
1  ED,  LEVELS  ABOVE  ",F5.0,"MB  DISREGARDED.") 

RETURN 

50  URITE  (IFC, 54)  (JSTC I ), I =4, 5) 

54  FORMAT  ( "< 15X 12> " , 3X, 2A2, "  AFREAD  ERROR  50  -  DECOS") 

RETURN  Q 

100  URITE  (IFC, 55)  (JSTC I ), I =4, 5) 

55  FORMAT  ( "< 15X 12> " , 3X, 2A2, "  AFREAD  ERROR  100  -  DECOS") 

RETURN  Q 

102  URITE  (IFC, 103)  (JSTC I ), I =4, 5) 
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103  FORMAT  ( "<  15X 12>",3X,2A2,  "  AFREAD  ERROR  102  -  DECOS") 

RETURN  Q 

125  WRITE  ( IFC, 56)  ( JST( I) , 1=4,5) 

56  FORMAT  ( "< 15X 12> " , 3X, 2A2, »  AFREAD  ERROR  125  -  DECOS") 

RETURN  Q 

126  WRITE  ( IFC, 57)  (JST( I) , 1=4,5) 

57  FORMAT  ( "< 15X 12> " , 3X, 2A2, "  STATION  MISSING  -  DECOS") 

RETURN  Q 

127  WRITE  (IFC, 129)  (JST(I) , 1=4,5) , IJJ, 1 1 

129  FORMAT  ( "< 15X 12> " , 3X, 2A2,  "  IMPROPER  FORMAT  (1ST  LINE)  LOOKING  FOR: 

1  " , 13, "  FOUND:  ",I3,"  DECOS") 

RETURN  Q 

128  WRITE  (IFC, 130)  (JSTCI) , 1=4,5) , IJK,JI 

130  FORMAT  ( "< 15X 12>",3X,2A2, "  IMPROPER  FORMAT  (2ND  +  LINE)  LOOKING  FOR 

1  " , 13, "  FOUND:  ",I3,"  DECOS") 

RETURN  Q 

900  WRITE  (IFC, 131)  ( JST( I ) , I =4,5) 

131  FORMAT  ( " < 1 5 >< 1 2 > " , 3X, 2 A2 , "  SGL  RAOB  ERROR  -  SUBROUTINE  ITCVT") 
RETURN  Q 

901  WRITE  (IFC,  132)  ( JST( I ) , I =4, 5) 

132  FORMAT  ( "< 15X 12> " , 3X, 2A2,  "  SGL  RAOB  ERROR  -  SUBROUTINE  FTCVT" ) 
RETURN  Q 

133  WRITE  (IFC, 134)  ( JST( I) , 1=4,5) 

134  FORMAT  ( "< 15X 12> " , 3X, 2A2, "  NEW  RAOB  NOT  AVAILABLE") 

RETURN  Q 

135  WRITE  (IFC, 136)  ( JST( I ) , I =4, 5) 

136  FORMAT  ( "< 15X 12> " , 3X, 2A2, "  DESIRED  VERSION  NOT  FOUND  -  DECOS") 
RETURN  Q 

END 

* 


* 

SUBROUTINE  TEMPI  (T, TD) 

C  COMPUTES  +  OR  -  TEMPERATURE,  AND  COMPUTES  DEWPOINT 
TT=AMOD (T, 2 . ) 

IF  (TT.EQ.l.)  T— T 
T=T*. 1 

IF  (TD.EQ.999.)  RETURN 
IF  (TD.LE.50. )  GO  TO  1 
TD=T- (TD-50 . ) 

RETURN 

1  TD=T-TD*.  1 

RETURN 
END 


* 

C  SUBROUTINE  -RANN2-  COMPUTES  ENERGY  AREAS  ON  THERMODYNAMIC  DIAGRAM, 

C  USING  PARCEL  METHOD,  WITH  SELECTED  ENTRAINMENT  RATE  AND  PRESSURE  STEP 
C  JNOJ  =  NO.  OF  LEVELS  IN  RAOB:  PA, TSA, TSDA 
C  PX  =  PRESSURE  LEVEL  ENDING  "Bl"  INDEX  COMPUTATION 

C  IMPORTANT. . .KMOD  MUST  BE  PROPERLY  SET,  BEFORE  THIS  SUBROUTINE  IS  CALLED. 
C  IF  KMOD  =  -1  BELOW  STATEMENT  108,  THEN  CCL  MODIFIED  RAOB  IS  USED. 
SUBROUTINE  RANN2  (PA, TSA, TSDA, JNOJ, PX) 

COMMON/S/JST ( 5 ) , KDATE ( 3 ) , IHOUR, JNO, JJNO, P (0 : 50) , TS (0 : 50) , TSD (0 : 50) 
COMMON/G/PP (0 : 20) , ET(20) , TW(0 : 50) , DP, EFF, KMOD, KK 
COMMON/T/RLCL, RLFC, EL, B2, B2P, B2N, I ALL, B 1 , B IP, B IN, EX 
COMMON/CCL/PCCL , ETCCL , TS0 , TSD0 , L , TSCCL , TCCL , TDCCL, WAVG 
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DIMENSION  PA (0:50) , TSA (0:50) , TSDA (0:50) 

THETA(T,P2,P1)=T*(P2/P1)**.2857142  ;  DRY  ADIABATIC  (T,P1)  TO  (THETA, P2) 
KDP=0  ;  KDP  RESET  TO  1,  IF  2ND  PASS  THRU  RANN2,  UITH  REDUCED  DP 

DPSAVE=DP  ;  SAVES  ORIGINAL  DP,  PASSED  THRU  COMMON/G 

R=287.04  ;  GAS  CONSTANT  FOR  DRY  AIR  ..  J/KG  PER  DEG  K 

R=R*. 1  ;  SCALING  ENERGY  UNITS 

EF1=.00002*EFF  ;  ENTRAINMENT  FACTOR  PER  MILLIBAR 

KMOD=KMOD- 1  ;  KMOD  =  -1,  UHEN  OPERATING  ON  CCL  MODIFIED  RAOB 

108  IF  (KMOD.EQ.-l)  GO  TO  106 
TS0=TSA (0) 

TSD0=TSDA (0) 

106  IF  (TS0.NE.TSD0)  GO  TO  92 

TC=TS0  ;  PARCEL  INITIALLY  SATURATED 
RLCL=PA (0) 

GO  TO  107 

92  TC=TCONOF (TS0, TSD0)  ;  CONDENSATION  TEMP 

PC=PA(0)*( (TC+273. 16) /(TS0+273 . 16) )**( 1 2857142)  ;  COND.  PRES. 

IF  (KMOD.EQ.-l)  PC=PCCL  ;  PC  COMPUTED  ABOVE  IS  NOT  EXACTLY  PCCL 

107  TH=THETA (TS0+273 .16, 1000 . , PA (0) ) -273 . 16  ;  POT.  TMP  DEG  C 

UTH=UOBF (TH) 

UTC=UOBF (TO 

THU=TH-UTH+UTC  ;  EQUIV  UET  BULB  POT  TMP  (DEG  C) 

C  LIFT  DRY  AD  I ABATICALLY  UNTIL  TP=TC  AT  PRESSURE  PC 
DO  7  1=1,20 
7  ET( I ) =0 . 

DTI =0 . 

IF  (KMOD.EQ.-l)  DTI =TS0-TSA (0) 

J  =0 
J  J  =0 
JK=0 
KJ=0 
EN=0 . 

EP=0 . 

P 1  =PA ( J) 

PP ( 0 ) =PA (0) 

KK  =  1 
KKK=0 
TP=TSA ( J) 

IF  (KMOD.EQ.-l)  TP=TS0 

IF  (TSDA(J) .EQ.999. )  TSDA(J) =TSA(J)-30.  ;  IF  MISG,  ASSUME  DRY 
UP=UMROF (PI, TSDA ( J) ) 

IF  ( IALL.EQ.2)  URITE  (10,86) 

86  FORMAT  (1H  , "PI", 8X, "P2 " , 10X, "TE " , 13X, "TP " , 13X, "DTI " , 12X, "DT2 " , 

1  12X, "E") 

IF  (TS0.EQ.TSD0)  GO  TO  15  ;  PARCEL  INITIALLY  SATURATED 

13  P2=P 1-DP 

MJ=0 

IF  (PC-P2)  3,4,4 
4  P2=PC 

RLCL=PC  ;  LIFTING  CONDENSATION  LVL 
3  IF  (PA (J+l ) -P2)  5,6,6 

6  P2=PA ( J+l ) 

J=J+1 
MJ=  1 
KJ=  1 

30  PLOG 1 =ALOG (PA ( J) /PA ( J+l ) ) 

FACTORT= (TSA ( J) -TSA ( J+l ) ) /PLOG 1 

IF  (TSDA(J+1) .EQ.999.)  TSDA ( J+l ) =TSA ( J+l ) -30 .  ;  IF  MISG,  ASSUME  DRY 
FACTORD= (TSDA (J) -TSDA (J+l ) ) /PLOG1 
KJ=  1 
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5  IF  (KJ.EQ.0)  GO  TO  30  ;  INSURES  FACTORED  COMPUTED  1ST  TIME  THRU 

IF  (JJ.EQ.0)  TP0=TP  ;  SAVE  ORIGINAL  TP 

IF  (JJ.EQ.l)  TP®TP0  ;  RESETS  TP  TO  ORIGINAL  VALUE,  IF  P2  ADJUSTED 
TP*TP+273. 16  ;  CONVERT  TO  DEG  K 

TP=THETA  (TP,P2,Pl)-273. 16  ;DRV  ADIABATIC  LIFT  PI  TO  P2  DEG  C 
PL0G2-AL0G (P2/PA ( J+l ) ) 

TE=TSA(J+1)+PL0G2*FACT0RT  ;  ENVIRONMENTAL  TEMP  AT  P2 
DP  1 =P 1-P2 

IF  (KMOD.EQ.-l)  GO  TO  42  ;  NO  ENTRAINMENT  BELOU  CCL  LEVEL 

IF  (EFF.EQ.0. )  GO  TO  42  ;  EFF=0 .  FOR  NO  ENTRAINMENT 

EF=EF1*DP1 

TP = (TP+273 .  16+EF*(TE+273 . 16) ) /( 1 .  +EF) -273 . 16  ;  DEG  C 

TDE=TSDA(J+1)+PL0G2*FACT0RD  ;  DEG  C 
UE =UMROF ( P2 , TDE )  ;  G/KG  MIXING  RATIO  OF  ENVIRONMENT 

UP=(UP+EF*UE)/( 1 .+EF)  ;  MIXING  RATIO  OF  PARCEL  AFTER  MIXING 

X=.0200*(TP- 12. 5+7500. /P2)  ;  CORRECTION  FOR  NON-IDEAL  GAS 

UFU=1 .+.0000045*P2+.00140*X*X  ;  CORRECTION  FOR  NON- IDEAL  GAS 
E2=UP*. 00 l*P2/(  (UP*. 00 1+. 62 197) *UFU)  ;  VAPOR  PRES  (MB)  OF  PARCEL 
ES2=VAPFU(TP)  ;  SATURATION  VAPOR  PRES  OF  PARCEL 
ES=ES2-E2 

IF  (ES)  40,40,41  ;  GOES  TO  40,  IF  PARCEL  SATURATED 

41  IF  (ES.LE..01)  GO  TO  40  ;  CLOSE  ENOUGH  FOR  SATURATION 

TDP=DPTOF (E2)  ;  DEUPOINT  OF  PARCEL  AFT  MXG  (DEG  C) 

TC=TCONOF  (TP, TDP) 

PC=P2*( (TC+273. 16) /(TP+273. 16) )**( 1.x. 2857 142) 

GO  TO  42 
40  TC=TP 

PC=P2 
RLCL=PC 

C  SINCE  LCL  HAS  BEEN  CHANGED,  NEU  -THU-  IS  ALSO  REQUIRED 

TH=THETA( TC+273. 16, 1000 ., PC) -273 . 16  ;  POT  TEMP  DEG  C 

UTH=UOBF (TH) 

UTC=UOBF (TC) 

THU=TH-UTH+UTC 

42  DT2=TP-TE 

IF  (JJ.EQ.0)  GO  TO  96 

TI=DT1-DT2 

JJ=0 

JK=  1 

IF  (TI)  10,10,11 

96  IF  (KMOD.NE.-l)  GO  TO  14 

IF  (P2.GT.PC)  GO  TO  14 
KKK  =  1 

GO  TO  11  ;  LAST  STEP  IN  COMPUTING  CCL  ENERGY 

14  IF  (JK.NE.l)  GO  TO  66  ;  JK-1,  IF  PREVIOUS  PASS  UAS  A  CROSSING  PT 

JK=0 

IF  (DT2)  10,10,11 

66  IF  (DT2)  8,8,9 

8  IF  (DTI)  10,10,12 

9  IF  (DTI)  12,11,11 

C  GOES  TO  12  IF  DRY  ADIABAT  CROSSES  ENVIRONMENTAL  TEMP 
12  P2=P 1-ABS (DTI ) /( ABS (DTI ) +ABS (DT2) ) *DP 1  ;  APPROX  PRES  UHERE  DT2=0. 

IF  (KK.LE.20)  GO  TO  75 
TYPE  "ET  DIMENSION  EXCEEDS  20" 

GO  TO  110 
75  KKK= 1 

JJ  =  1 

IF  (MJ.EQ.0)  GO  TO  5 

C  MJ=1  MEANS  J,  UHICH  HAS  JUST  BEEN  SET  AT  STATEMENT  6,  MUST  BE  RESET 
C  TO  INTERPOLATE  PROPERLY 
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J=J-1 

MJ=0 

GO  TO  30 

10  E  = . 5* ( DT2+DT 1 ) *ALOG ( P 1 /P2 ) 

EN=EN+E 

IF  (IALL.EQ.2)  URITE  (10,85)  P1,P2,TE,TP,DT1,DT2,E 
85  FORMAT  ( 1H  ,2F10.3,5E15.6) 

P 1  =P2 
DTI =DT2 

IF  (KKK . EQ . 0 . AND . P2 . NE . PA ( JNOJ) )  GO  TO  62 

ET(KK)  =EN*R  ;  CONVERTS  TO  J/KG  UNITS 

PPCKK) =P2 

KK=KK+1 

EN=0. 

KKK=0 

62  IF  (P2.EQ.PC)  GO  TO  15  ;  PARCEL  SATURATED 

GO  TO  13 

11  E=.5*(DT2+DT1)*AL0G(P1/P2) 

EP=EP+E 

IF  ( IALL.EQ.2)  URITE  (10,85)  P 1 , P2, TE, TP, DTI , DT2, E 
P 1  =P2 
DTI =DT2 

IF  (KKK . EQ . 0 . AND . P2 . NE . PA (JNOJ) )  GO  TO  63 
ET(KK) =EP*R  ;  CONVERTS  TO  J/KG  UNITS 
PP(KK) =P2 
KK=KK+1 
EP=0 . 

KKK=0 

63  IF  (P2.EQ.PC)  GO  TO  15  ;  PARCEL  SATURATED 

GO  TO  13 

C 

C  LIFT  PARCEL  ALONG  SATURATION  ADIABATIC 
C 

15  CONTINUE 

IF  (KMOD.NE.-l)  GO  TO  84 
DTI =0. 

ETCCL=ET( 1) 

RETURN  ;  REMOVE,  IF  FULL  COMPUTATION  OF  CCL  MODIFIED  SOUNDING  IS  DESIRED 
KK= 1  ;  KK  SET  FROM  2  BACK  TO  1,  CCL  ENERGY  HAS  JUST  BEEN  COMPUTED 

84  J J  =0 

JK=0 
ISTOP=0 
KKK=0 

24  P2=P 1-DP 
MJ=0 

IF  (PA ( J+l ) -P2)  16,17,17 
17  P2=PA ( J+l ) 

IF  (PA (J+l ) . GT. PA (JNOJ) )  GO  TO  25 
I STOP =1 
GO  TO  16 

25  J=J+1 
MJ=  1 

88  PLOG 1 =ALOG (PA ( J) /PA ( J+l ) ) 

FACTORT= (TSA ( J) -TSA ( J+l ) ) /PLOG 1 

IF  (TSDA ( J+l )  . EQ . 999 . )  TSDAU+1)  =TSA(J+l)-30.  ;  IF  MISG,  ASSUME  DRY 
FACTORD= (TSDA ( J) -TSDA ( J+l ) ) /PLOG 1 
KJ  =  1 

16  IF  (KJ.EQ.0)  GO  TO  88 

IF  (JJ.EQ.0)  THU0=THU  ;  SAVE  ORIGINAL  THU 

IF  (JJ.EQ.l)  THU=THU0  ; RESETS  THU  TO  ORIGINAL  VALUE,  IF  P2  ADJUSTED 
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TP-SATLFT  (THU,P2)  ;  TEMP  OF  PARCEL  AT  P2  ON  -THLK  UET  ADIABAT 
PL0G2=AL0G (P2/PA ( J+l ) ) 

TE=TSA(J+1)+PL0G2*FACT0RT  ;  ENVIRONMENTAL  TEMP  AT  P2 
DP1=P1-P2 

IF  (EFF.EQ.0. )  GO  TO  67  ;  EFF=0.  FOR  NO  ENTRAINMENT 

TDE-TSDA(J+1)+PL0G2*FACT0RD  ;  ENVIRONMENTAL  DEUPT  AT  P2 
UE=UMROF  (P2, TDE)  ;  MIXING  RATIO  (G/KG)  OF  ENVIRONMENT 
UP=UMROF  (P2,TP)  ;  MIXING  RATIO  OF  SATURATED  PARCEL 

EF-EF1*DP1 

UP=(UP+EF*UE)/( l.+EF) 

TP=(TP+273. 16+EF*(TE+273. 16) )/( 1 .+EF)-273. 16 

X=.0200*(TP- 12. 5+7500. /P2)  ;  CORRECTION  FOR  NON- IDEAL  GAS 

UFU=1 .+.0000045*P2+.00140*X*X  ;  CORRECTION  FOR  NON- IDEAL  GAS 

E2=UP*. 00  l*P2/(  (UP*. 00 1+. 62 197) *UFU)  ;  VAPOR  PRES  (MB)  OF  PARCEL 
TDP=DPT0F(E2)  ;  DEUPT  OF  PARCEL  AFT  MXG 
IF  (TDP.GT.TP)  TDP=TP 
TC=TCONOF (TP, TDP) 

TH=THETA (TP+273 .16, 1000 . , P2) -273 . 16  ;  POT  TEMP  DEG  C 
UTH=UOBF (TH) 

UTC=UOBF (TC) 

THU=TH-UTH+UTC  ;  EQUIV  UET  BULB  POT  TEMP  (DEG  C) 

TP=SATLFT (THU, P2)  ;  PARCEL  TEMP  AFT  EVAPORATING  LIQUID  UATER 

67  DT2=TP-TE 

C  IF  ADDITIONAL  INFORMATION  ON  LEVELS  IS  NEEDED,  INSERT  PRINT  STATEMENT  HERE 
IF  (JJ.EQ.0)  GO  TO  23  ;  JJ-1  IF  NEU  P2  HAS  BEEN  COMPUTED  FOR  CROSSOVER. 

TI=DT1-DT2 
J  J  =0 
JK  =  1 

IF  (TI)  20,20,22 

23  IF  (JK.NE.l)  GO  TO  65  ;  JK-1,  IF  PREVIOUS  PASS  UAS  A  CROSSING  PT 

JK=0 
C 

C  IN  CASE  SAT.  ADIABAT  INTERSECTS  ENVIRONMENTAL  TEMP  IN  2  PLACES  CREATING 

C  A  VERY  SMALL  POSITIVE  AREA,  THIS  AREA  UILL  BE  IGNORED  (STATEMENT  101). 

CHECK=DT2*ET (KK- 1 )  ;  USUALLY  NEGATIVE 
IF  (CHECK. LT.0.)  GO  TO  100 
IF  (DT2)  101,102,102 

101  EN=ET(KK- 1 ) 

KK=KK-  1 

TYPE  "STATEMENT  101  USED  IN  RANN2" 

GO  TO  20 

C  IF  STATEMENT  102  IS  USED,  PRESSURE  STEP  IS  REDUCED  AND  ENTIRE  COMPUTATION 

C  IS  REPEATED.  THIS  OCCURS  UHEN  DT2  CHANGES  SIGN  SEVERAL  TIMES  IN  A  SHORT 

C  PRESSURE  DISTANCE.  THIS  SHOULD  BE  A  VERY  RARE  OCCURENCE 

102  DP- 10.  ;  REDUCE  PRESSURE  STEP  TO  10MB. 

IF  (KDP.EQ.0)  GO  TO  109 

GO  TO  110  ;  RANN2  CANNOT  BE  COMPLETED  UITH  REDUCED  PRESSURE  STEP 

109  KDP=KDP+1 

TYPE  "STATEMENT  102  USED  IN  RANN2" 

GO  TO  108  ;  REPEAT  ENTIRE  ENERGY  CALCULATION  UITH  10MB  PRES  STEP 

C 

100  IF  (DT2)  20,20,22 

65  IF  (DT2)  18,18,19 

18  IF  (DTI)  20,20,21 

19  IF  (DTI)  21,22,22 

C  GOES  TO  21  IF  UET  ADIABAT  CROSSES  ENVIRONMENTAL  TEMP 
21  P2=P 1-ABS (DTI ) /( ABS (DTI ) +ABS(DT2) ) *DP 1 

IF  (KK.LE.20)  GO  TO  76 
TYPE  "ET  DIMENSION  EXCEEDS  20" 

GO  TO  110 
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76 


KKK  =  1 
JJ  =  1 

IF  (MJ.EQ.0)  GO  TO  16 
C  MJ-1  MEANS  J,  UHICH  HAS  JUST  BEEN  SET  AT  STATEMENT  25,  MUST  BE  RESET 
C  TO  INTERPOLATE  PROPERLY 
J=J-1 
MJ=0 

GO  TO  88 

20  E  = . 5* ( DT2+DT 1 ) *ALOG ( P 1 /P2 ) 

EN=EN+E 

IF  (IALL.EQ.2)  URITE  (10,85)  P 1 , P2, TE, TP, DTI , DT2, E 
P 1  =P2 
DTI =DT2 

IF  (P2.NE.PX)  GO  TO  99 

EX=EN*R  ;  SUBTOTAL  FOR  ENERGY  AREA  ENDING  AT  PX 

KX=KK 

99  IF  (KKK . EQ . 0 . AND . P2 . NE . PA ( JNOJ) )  GO  TO  60 

ET(KK) =EN*R  ;  CONVERTING  TO  J/KG  UNITS 
PP (KK) =P2 
KK=KK+1 
EN=0 . 

KKK=0 

60  IF  ( I STOP . EQ . 1 . AND . P 1 . EQ . PA (JNOJ) )  GO  TO  26 
GO  TO  24 

22  E=.5*(DT2+DT1)*AL0G(P1/P2) 

EP=EP+E 

IF  (IALL.EQ.2)  URITE  (10,85)  P1,P2,TE,TP,DT1,DT2,E 
P 1  =P2 
DTI =DT2 

IF  (P2.NE.PX)  GO  TO  104 

EX=EP*R  ;  SUBTOTAL  FOR  ENERGY  AREA  ENDING  AT  PX 
KX=KK 

104  IF  (KKK . EQ . 0 . AND . P2 . NE . PA (JNOJ) )  GO  TO  61 
ET(KK) =EP*R  ;  CONVERTING  TO  J/KG  UNITS 
PP (KK) =P2 
KK=KK+1 
EP=0 . 

KKK=0 

61  IF  ( ISTOP.EQ. 1 .AND. PI .EQ. PA (JNOJ) )  GO  TO  26 
GO  TO  24 

26  CONTINUE 

C 

C  KK  =  NUMBER  OF  ENERGY  AREAS  IN  SOUNDING  +  1 
KK 1 =KK- 1 
KK2=KK-2 
KK3=KK-3 
EL=0. 

B2=999 . 

B2P=999 . 

B2N=999 .  ;  999  DENOTES  THAT  VARIABLE  IS  UNDEFINED 

RLFC=0 . 

C  DETERMINE  -LFC-  LEVEL 

IF  (KK.EQ.2.AND.ET( 1) .GT.0. )  RLFC=PP(0) 

IF  (KK . EQ . 3 . AND . ET( 1 ) . LT. 0 . )  RLFC=PP(1) 

IF  (KK . GE . 4. AND . ET( 1 ) . LT. 0 . )  RLFC=PP(1) 

IF  (KK . GE . 4. AND . ET( 1 ) . GT. 0 . )  RLFC=PP(2) 

C  IN  ALL  OTHER  CASES  RLFC  IS  UNDEFINED. . . RLFC=0. 

C 

IF  (ET(KKl) .GT.0.)  GO  TO  70  ;  HIGHEST  AREA  IS  +,  NO  INDICES  COMPUTED 

C  -EL-  LEVEL  DETERMINED  HERE 
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EL=PP (KK2) 

C  COMPUTE  ENERGY  INDICES  BELOU  EL  LEVEL 

IF  (KK.EQ.2)  GO  TO  70  ;  ONLY  ONE  LAYER,  ALL  NEGATIVE 

B2-0. 

B2P*0. 

B2N=0. 

IF  (ET(l)  . LT.0. )  GO  TO  58 
DO  74  1=1, KK2, 2 
74  B2P=B2P+ET ( I ) 

IF  (KK.GT.3)  GO  TO  68 
B2N=0. 

GO  TO  69 

68  DO  73  I =2, KK3, 2 

73  B2N=B2N+ET( I) 

GO  TO  69 

58  DO  91  1=1, KK3, 2 

91  B2N=B2N+ET ( I ) 

DO  103  I =2, KK2, 2 
103  B2P=B2P+ET( I) 

69  B2=B2P+B2N 

70  CONTINUE 
C 

C  COMPUTE  B 1  INDEX  (ENERGY  AREAS  ENDING  AT  PX) 

KX1 =KX- 1 
B 1  =0 . 

B  1P=0 . 

B  1N=0 . 

DO  105  1=1, KX1 

IF  (ET( I) .LT.0. )  B 1N=B 1N+ET ( I ) 

IF  (ETC  I ) . GT. 0 . )  B 1P=B 1P+ET ( I ) 

105  CONTINUE 

IF  (EX. LT.0.)  B 1N=B 1N+EX 
IF  (EX. GT. 0 . )  B 1P=B 1P+EX 
B 1 =B 1P+B IN 
RETURN 

C  GOES  TO  110,  IF  RANN2  CANNOT  BE  COMPLETED  DUE  TO  MANY  SIGN  CHANGES  OF  DT2 

C  OVER  A  SMALL  PRESSURE  INTERVAL,  OR  TOO  MANY  ENERGY  AREAS  (KK.GT.20). 

110  EL=0. 

B 1=999. 

B 1P=999 . 

B 1N=999 . 

B2=999 . 

B2P=999. 

B2N=999 . 

URITE  (10,111)  (JST(I), 1=4,5) 

111  FORMAT  (1H  , 2A2,  "  RANN2  SUBROUTINE  DID  NOT  COMPLETE.11) 

DP=DPSAVE  ;  RESTORE  DP  TO  ORIGINAL  VALUE,  IF  IT  UAS  CHANGED. 
RETURN 

END 

* 


* 

SUBROUTINE  CCL1  (IFC,Q) 

C  COMPUTES  CCL  AND  CONVECTIVE  TEMPERATURE 

C0MM0N/S/JST(5),KDATE(3), IHOUR,JNO,JJNO,P (0:50), TS (0:50), TSD (0:50) 
COMMON/CCL/PCCL, ETCCL, TS0, TSD0, L, TSCCL, TCCL, TDCCL, UAVG 
INTEGER  Q 

THETA(T,P2,P1) =T*(P2/P 1 )**. 2857 142  ;  DRY  ADIABATIC  (T, P 1 )  TO  (THETA, P2) 
DP1=100.  ;  AVERAGES  MIXING  RATIO  OVER  FIRST  -DPI-  MBS. 
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USUM=0 . 

J=0 

P1=P(0) 

TDE1=TSD(0) 

Ul=UliROF  (P(0)  , TDE1) 

PF IN ISH=P 1-DP  1 

3  P2=PF IN ISH 

IF  (P( J+l)-P2)  1,2,2 
2  P2=P( J+l) 

TDE2=TSD ( J+l )  ;  ENVIRONMENT  DEUPT  AT  P2 

J=J+1 

GO  TO  9 

1  PL0G1=AL0G(P(J)/P(J+D) 

FACTORD=(TSD(J)-TSD(J+l))/PLOGl 
PL0G2=AL0G(P2/P(J+1) ) 

TDE2=TSD(J+1)+FACT0RD*PL0G2  ;  ENVIRONMENT  DEUPT  AT  P2 
9  U2  =UMROF ( P2 , TDE2 )  ;  MIXING  RATIO  AT  P2 

PL0G3=AL0G (P 1/P2) 

U=.5*(U1+U2)*PL0G3  ;  AVG  MIX  RATIO  IN  LYR  P1-P2 

USUM=USUM+U 
P 1  =P2 
U1  =U2 

IF  CP2.GT.PFINISH)  GO  TO  3 
C  COMPUTE  AVG  VALUES  FOR  FIRST  -DPI-  MBS. 

PLOG4=ALOG (P (0) /PF IN ISH) 

UAVG=USUM/PLOG4 

C  DETERMINE  LAYER  CONTAINING  CCL,  CHECKING  FROM  TOP  OF  ATMOS  DOUNUARD 
DO  4  I =0, JNO 
1 1 =JNO- 1 

US  =UMROF ( P  C 1 1 ) , TS ( 1 1 ) ) 

IF  (US-UAVG)  4,5,6 

4  CONTINUE 

URITE  (10,8)  (JST(I), 1=4,5) 

8  FORMAT  (1H  ,2A2,"  ERROR  IN  CCL1") 

STOP 

5  PCCL=P (II) 

TCCL=TS (II) 

TDCCL=TSD (II) 

TSCCL=THETA (TCCL+273 . 16,P(0), PCCL) -273 . 16  ;  CONVECTIVE  TEMP  DEG  C 

L=JNO+l 

JJNO=JNO- 1 

RETURN  ;  CCL  LEVEL  IS  ALSO  A  RAOB  SIGNIFICANT  LEVEL 

6  J-II+1 
JJNO=JNO 

IF  (J.EQ. (JNO+1) )  GO  TO  32  ;  SHORT  RAOB 

C  MXG  RATIO  INTERSECTS  ENVIRONMENTAL  TEMP  BTUN  P(J)  AND  P(J-l) 

C  THIS  LAYER  UILL  BE  SUBDIVIDED  UNTIL  SATURATION  VAPOR  PRESSURE  AT 
C  MIDPOINT  OF  LAYER  IS  SUFFICIENTLY  CLOSE  (.01  G/KG)  TO  UAVG. 

C  THIS  DETERMINES  THE  CCL  LEVEL. 

P 1  =P ( J- 1 )  ;  BOTTOM 

P2=P ( J)  ;  TOP 

T1=TS(J-1)  ;  BOTTOM 

T2=TS ( J)  ;  TOP 

31  ALOG 1 =ALOG (P 1/P2) 

PM= . 5*(P 1+P2)  ;  MIDPOINT  PRESSURE 

AL0G2=AL0G (PM/P2) 

TPM=T2+(T1-T2)/AL0G1*AL0G2  ;  MIDPOINT  TEMPERATURE 

USM=UMROF (PM, TPM)  ;  MIDPOINT  SATURATION  MIXING  RATIO 
IF(ABS(USM-UAVG) .LE. .01)  GO  TO  29  ;  TEST  FOR  TOLERANCE 

IF  (USM-UAVG)  28,29,30 
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cm  a 


28 


P2*PM 
T2=TPM 
GO  TO  31 
30  P 1 =PM 

T1 =TPM 
GO  TO  31 

29  PCCL-PM  ;  CCL  PRESSURE 

TCCL=TPM  ;  CCL  TEMPERATURE 
C  COMPUTE  DEUPOINT  AT  CCL  LEVEL 
ALOG 1 =ALOG (P ( J- 1 ) /P ( J) ) 

AL0G2=AL0G (PM/P ( J) ) 

TDCCL=TSD(J)+(TSD(J-1)-TSD(J))/AL0G1*AL0G2 

IF  (TDCCL.GT.TCCL)  TDCCL=TCCL  ;  CORRECTION  FOR  DEUPOINT  EXCEEDING 
1  TEMPERATURE  BY  SMALL  AMT 

TSCCL=THETA (TCCL+273 . 16, P (0) , PCCL) -273 . 16  ;  CONVECTIVE  TEMP  DEG  C 

L=J  ;  INDEX  NUMBER  OF  ADDED  CCL  LEVEL 

RETURN 

32  URITE  (IFC,33)  ( JST( I ) , I =4, 5) , P ( JNO) 

33  FORMAT  ( "< 15X 12>",3X,2A2, "RAOB  TERMINATES  TOO  SOON,  P(JNO)  =  ", 

1  F5.0, "  CCL 1 " ) 

RETURN  Q 
END 

* 


* 

C  THIS  SUBROUTINE  TO  BE  CALLED  AFTER  -CCL1-  IS  CALLED 
SUBROUTINE  MODRB 

C0MM0N/S/JST(5),KDATE(3), IHOUR, JNO, JJNO,P (0:50), TS (0:50), TSD (0:50) 
COMMON/CCL/PCCL, ETCCL, TS0, TSD0,L, TSCCL, TCCL, TDCCL, UAVG 
COMMON/TT/PT ( 0 : 50 ) , TST ( 0 : 50 ) , TSDT (0:50) 

COMMON/V/JNOM,  PX 
C  MODIFY  ORIGINAL  RAOB  FOR 
TS0=TSCCL 

IF  (L.EQ.  (JNO+D)  GO 
C  MOVE  SGFNT  LVLS  ABV  PCCL 
I  =JNO 

1  TST ( 1+1 ) =TS ( I ) 

TSDT ( 1  +  1 ) =TSD ( I ) 

PT( I+l)-P( I) 

1  =  1-1 

IF  (I.GE.L)  GO  TO  1 
C  ONE  ADDITIONAL  LVL  ADDED 
TST (L) =TCCL 
TSDT(L) =TDCCL 
PT(L) =PCCL 

C  COMPLETE  THE  RAOB  BELOU  THE  CCL  LEVEL 
3  LL=L-1 

DO  2  1=0, LL 
TST ( I ) =TS ( I ) 

TSDT ( I ) =TSD ( I ) 

PT( I) =P( I) 

MODIFY  TSD (0)  TO  CONFORM  TO  UAVG,  AVG  MIXING  RATIO  IN  LOUEST  100  MBS 
X= . 0200* (TSDT (0) - 12 . 5+7500 . /PT (0) )  ;  NON-IDEAL  GAS  CORRECTION 

UFU=1 .+.0000045*PT(0)+.00140*X*X  ;  NON-IDEAL  GAS  CORRECTION 

E2=.001*UAVG*PT(0)/((UAVG*.001+.62197)*UFU)  ;  VAPOR  PRESSURE 

TSD0=DPTOF(E2) 

JNOM=JJNO+l 
RETURN 
END 


SOLAR  HEATING  BLO  CCL 
;  SFC  TEMP  RESET 

TO  3  ;  CCL  LEVEL  IS  A  RAOB  SGFNT  LEVEL 

UP  ONE  LVL 


AT  PCCL 


-31- 


SUBROUTINE  INDX1  (RLI,RKI,RUI,Q, IFC) 

COMPUTES  LIFTED  INDEX,  K  INDEX,  AND  SHOUALTER  INDEX 
IF  SFC  PRES  LESS  THAN  850MB,  K  AND  SHOUALTER  SET  =  999. 

IFC  DENOTES  OUTPUT  DEVICE  FOR  ERROR  MSG  FM  THIS  SUBROUTINE 

COMMON/S/JST (5) , KDATE (3) , IHOUR, JNO, JJNO,P (0:50) ,TS (0:50) ,TSD(0: 50) 
DIMENSION  PL(3),TL(3), TDL ( 3 ) 

INTEGER  Q 

THETA(T,P2,P1)=T*(P2/P1)**.2857142  ;  DRY  ADIABATIC  (T,P1)  TO  (THETA, P2) 
IH I =0  ;  INDICATOR  FOR  SFC  PRESSURE  GREATER  THAN  850MB. 

PL ( 1) =850. 

PL (2) =700. 

PL(3) =500. 

DP  1=50.  ;  AVERAGES  OVER  FIRST  -DPI-  MBS. 

USUM=0 . 

THSUM=0 . 

J  =0 

P 1  =P ( 0 ) 

TE 1 =TS (0) 

TDE 1 =TSD (0) 

TH 1 =THETA (TE 1+273 .16, 1000 . , P (0) )  ;  POT  TEMP 

U1 =UMROF (P (0) , TDE 1 ) 

PF  IN ISH=P 1-DP  1 
P2=PF IN ISH 
IF  (P ( J+l ) -P2)  1,2,2 
P2=P ( J+l ) 


J=J+1 


PLOG 1 =ALOG (P ( J) /P ( J+l ) ) 
FACTORT=(TS(J)-TS(J+l))/PLOGl 
FACTORD= (TSD (J)-TSD( J+l)) /PLOG 1 
PL0G2=AL0G (P2/P ( J+l ) ) 
TE2=TS(J+1)+FACT0RT*PL0G2  ; 
TDE2=TSD ( J+l ) +FACT0RD*PL0G2  ; 
TH2=THETA (TE2+273 . 16, 1000., P2) 
U2=UMR0F (P2, TDE2) 
PL0G3=AL0G(P1/P2) 

TH  = .  5*  ( TH  1 +TH2 )  *PL0G3 
U= . 5*(U1+U2) *PL0G3 
THSUM=THSUM+TH 
USUM=USUM+U 


ENVIRONMENT  TEMP  AT  P2 
ENVIRONMENT  DEUPT  AT  P2 
;  POT  TEMP  AT  TE2, P2 
;  MIXING  RATIO  AT  P2 

;  AVG  POT  TEMP  IN  LYR  P1-P2 
;  AVG  MIX  RATIO  IN  LYR  P1-P2 


P 1  =P2 


TH 1 =TH2 
U1=U2 


IF  (P2.GT.PFINISH)  GO  TO  3 
COMPUTE  AVG  VALUES  FOR  FIRST  -DPI-  MBS. 

PLOG4=ALOG (P (0) /PF IN ISH) 

THAVG=THSUM/PLOG4 
UAVG=USUM/PLOG4 
PPARCEL=P (0) - . 5*DP 1 

TPARCEL=THETA (THAVG, PPARCEL, 1000.)-273. 16  ;  DEG 

X=.0200*(TPARCEL- 12. 5+7500. /PPARCEL)  ;  NON- IDEAL 
UFU= 1 .  +  .  0000045*PPARCEL+.  00  140*X>kX  ;  NON- IDEAL 

E2=.001*UAVG*PPARCEL/(  (UAVG*. 00 1+. 62 197) *UFU)  ; 
TDPARCEL=DPT0F(E2) 

TC=TCONOF (TPARCEL, TDPARCEL) 

TH=THAVG-273 . 16  ;  POT  TEMP  DEG  C 

UTH=UOBF (TH) 


C 

GAS  CORRECTION 
GAS  CORRECTION 
VAPOR  PRES  (MB) 


UTC=UOBF  CTC) 

THU-TH-UTH+UTC  ;  EQUIV  LET  BULB  POT  TEMP  (DEG  C) 

TP500=SATLFT(THU, 500 . ) 

C  GET  TEMP  AND  DELFT  AT  850,700,500  MBS 
DO  5  J  =  1 , 3 
DO  4  I«0,JNO 
IF  (PL(J)-P(I))  4,6,7 

4  CONTINUE 

URITE  (IFC,  10)  (JST(I), 1=4,5), P(JNO) 

10  FORMAT  ( "<  15><  12>",3X,2A2,  11  RAOB  TERMINATES  TOO  SOON,  P(JNO)  =  ",F5.0) 

RETURN  Q 

6  TL  ( J) =TS ( I ) 

TDL ( J) =TSD ( I ) 

GO  TO  5 

7  IF  (J.NE.  1)  GO  TO  8 

IF  (I.NE.0)  GO  TO  8 
IH I  =  1 

GO  TO  5  ;  SFC  PRESSURE  LESS  THAN  850MB 

8  FACTOR=ALOG(PL(J)/P( I))/ALOG(P( I-l)/P( I)) 

TL ( J) =TS ( I ) +FACTOR*(TS ( I- 1 ) -TS ( I ) ) 

TDL(J) =TSD( I )+F ACTORS (TSD( I-1)-TSD( I) ) 

5  CONTINUE 

RL I =TL (3) -TP500  ;  LIFTED  INDEX 

IF  (IHI.EQ.0)  GO  TO  9  ;  COMPUTE  K  AND  SHOUALTER  INDICES 

RK I =999 .  ;  K  INDEX  MISG 

RUI =999 .  ;  SHOUALTER  INDEX  MISG 

RETURN 

9  RK I = (TL ( 1 ) -TL (3) ) +TDL ( 1 ) - (TL (2) -TDL (2) )  ;  K  INDEX 
C  COMPUTE  SHOUALTER  INDEX 

TC  =TCONOF ( TL ( 1 ) , TDL ( 1 ) ) 

TH=THETA (TL ( 1 ) +273 .16, 1000 . , 850 . ) -273 . 16  ;  DEG  C 

UTH=UOBF (TH) 

UTC=UOBF (TC) 

TH U = TH - UTH  +UTC  ;  EQUIV  UET  BULB  POT  TEMP 
TP=SATLFT (THU, 500 . ) 

RUI =TL (3) -TP  ;  SHOUALTER  INDEX 

RETURN 

END 

* 


* 

SUBROUTINE  BNDX  (IFC,Q) 

C  DETERMINES  LEVEL  OF  MAXIMUM  INSTABILITY  IN  LOUER  150MBS  OF  RAOB, 

C  ADJUSTS  ORIGINAL  RAOB,  SO  LEVEL  OF  MAX  INSTABILITY  IS  FIRST  SGFNT 

C  LEVEL  AND  ADDS  ADDITIONAL  PRES  LEVEL  PX,  IF  PX  IS  NOT  A  SGFNT  LEVEL. 

C  IF  RAOB  TERMINATES  BELOU  PX,  IT  IS  EXTRAPOLATED  TO  PX,  IF  TOP  LEVEL  IS  UITHIN  50  MBS 
C  IFC  DENOTES  OUTPUT  DEVICE  FOR  ERROR  MSG  FM  THIS  SUBROUTINE. 

C0MM0N/S/JST(5),KDATE(3), IHOUR, JNO, JJNO, P (0:50), TS (0:50) ,TSD (0:50) 

COMMQN/TT/PT(0 : 50) , TST (0:50), TSDT (0:50) 

COMMON/V/JNOM, PX 
DIMENSION  PB (2) , TB (2) , TDB (*_) 

INTEGER  Q 

THETA (T, P2, P 1 ) =T*(P2/P 1 ) **.2857142  ;  DRY  ADIABATIC  (T,P1)  TO  (THETA, P2) 

DP2= 150 . 

C  GET  TEMP  AND  DEUPT  AT  P(0)-DP2  AND  PX 
PB ( 1 ) =P (0) -DP2 
PB (2) =PX 
DO  5  J=l,2 
DO  4  1=0, JNO 
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IF  (PB(J)-P(I))  4,6,7 

4  CONTINUE 
1  =  1-1 

IF  (J.EQ.2. AND. (P ( JNO) -PB (2) ) .LT.50. )  GO  TO  7  ;  EXTRAPOLATES,  IF  UITHIN  50MBS 
URITE  ( IFC,3)  (JST(I), 1=4,5), P(JNO) 

3  FORMAT  ( "< 15>< 12>",3X,2A2, "  RAOB  TERMINATES  TOO  SOON,  P(JNO)  =  ",F5.0,"  BNDX") 

RETURN  Q 

6  TB(J)-TS(I) 

TDB( J) =TSD ( I ) 

GO  TO  5 

7  FACTOR =ALOG (PB (J) /P ( I)  )/ALOG(P(  I-l)/P(  I) ) 

TB ( J) =TS ( I ) +FACTOR*(TS ( I- 1 ) -TS ( I ) ) 

TDB(J)  =TSD ( I )  +FACTOR*(TSD ( I- 1 ) -TSD ( I) ) 

5  CONTINUE 

C  FIND  LARGEST  POTENTIAL  UET  BULB  TEMPERATURE  IN  FIRST  DP2  MBS 
THUMAX=- 1000 . 

11=0 

DO  1  1=0, JNO 
IF  (P(I)-PB(l))  8,10,10 

10  TC=TCONOF  (TS ( I ) , TSD ( I ) ) 

TH=THETA (TS ( I ) +273 .16, 1000 . ,  P  ( I ) ) -273 . 16  ;  DEG  C 
UTH=UOBF(TH) 

UTC=LJOBF  (TO 

TH U = TH - UTH  +UTC  ;  UET  BULB  POTENTIAL  TEMPERATURE 
IF  (THU-THUMAX)  1,1,2 
2  THUMAX=THU 

1 1  =  I 

PMAX=P( D 
TMAX=TS( I) 

TDMAX=TSD( I) 

1  CONTINUE 

8  IF  (P(I-l) .EQ.PB(l))  GO  TO  9 

TC=TCONOF  (TB( 1) ,TDB( 1) ) 

TH=THETA(TB( l)+273. 16, 1000. ,PB( 1) )-273. 16  ;  DEG  C 

UTH=UOBF (TH) 

UTC=UOBF (TC) 

THU=TH-UTH+UTC  ;  UET  BULB  POT  TEMP 
IF  (THU-THUMAX)  9,9,12 
12  THUMAX=THU 

11=1-1 
PMAX=PB( 1) 

TMAX=TB ( 1 ) 

TDMAX=TDB ( 1 ) 

9  CONTINUE 

C  MODIFY  RAOB  SO  LOUEST  LEVEL  HAS  MAXIMUM  UET  BULB  POTENTIAL  TEMPERATURE 
PT (0) =PMAX 
TST (0) =TMAX 
TSDT(0) =TDMAX 
JNOO=JNO- 1 1 
DO  11  J=l, JNOO 
PT( J) =P(J+I I) 

TST ( J) =TS ( J+I I ) 

TSDT(J) =TSD ( J+I I ) 

11  CONTINUE 

DO  14  J=l, JNOO 
IF  (PB (2) -PT ( J) )  14,17,16 
14  CONTINUE 

J=JNOO+l 

GO  TO  20  ;  EXTRAPOLATE  RAOB 

16  I = JNOO 
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MOVE  ALL  LEVELS  ABOVE  PB<2)  UP  1  LEVEL 


TST(I+1)«TST(I)  ; 

TSDT (I + 1 ) =TSDT ( I ) 

PTC  1  +  1) "PTC  I) 

1  =  1-1 

IF  (I.GE.J)  GO  TO  18  ;  J  SET  IN  DO  14  LOOP 

20  TSTC J) =TB(2)  ;  ADD  TBC2)  LEVEL 

TSDTC J) *TDB (2) 

PTC J) =PB (2) 

JNOM=JNOO+l 
GO  TO  19 

1?  JNOM=JNOO 

19  CONTINUE 

RETURN 
END 

* 


* 

SUBROUTINE  DECOM  C 1ST, IDATE, IHOUR,Z,T,TD,D,S,Q, IFD,PTROP) 

C  DECODES  MANDATORY  LVL  RAOB  DATA  UP  TO  AND  INCLUDING  MAX  UND  (77/66  GRP) 

C  SUBROUTINE  SEARCHES  FOR  SPECIFIED  DATE  C IDATE)  &  HOUR  CIHOUR) 

C  1ST. . . AFOS  IDENTIFER,  IFD ...  OUTPUT  DEVICE 
C  Q... ABNORMAL  ERROR  RETURN  STATEMENT  NUMBER 

C  2...C0  =  SFC  PRES) ,  Cl, 2 _ 10  =  HGTS) ,  Cll  =  TROP  DATA),  (12  =  MAX  UND) 

C  T. . .TEMPERATURE,  TD . . . DEUPO INT,  D...UND  DIR,  S...UND  SPEED 
C  TC 12)  =  LOUER  UIND  SHEAR,  TDC12)  =  UPPER  UIND  SHEAR 
C  PTROP  =  Z(ll)  IS  TROP  PRESSURE  FROM  "88"  GROUP,  THIS  REDUNDANCY  FOR 
C  BENEFIT  OF  RANP  PROGRAM! 

C 


c 

MISSING  DATA 

i  INDICATED  AS  FOLLOUS 

i: 

c 

HEIGHT 

Z(  1 . 10) 

— 

999 

c 

PRESSURE 

ZC 11, 12) 

999 

c 

TEMPERATURE 

T  &  TD  ( 1 ,  .  .  . ,  1 1 ) 

999 

c 

UND  SHEAR 

T  8,  TDC12) 

j-* 

999 

c 

UND 

D  &  S (0 . 12) 

-99 

C 

INTEGER  Q 

DIMENSION  IST(5),Z(0: 12),T(0: 12),TD(0: 12),D(0: 12),S(0: 12), IOUTC40) 
COMMON/S I/ISC0: 12) 

DATA  IS/99, 00, 85, 70, 50, 40, 30, 25, 20, 15, 10,88,77/ 

KS=0  ;  INDICATOR  FOR  LAST  LEVEL  OF  UIND  DATA  REPORTED 
CALL  AFREAD  Cl, 1ST, $100) 

CALL  AFREAD  (2, IOUT, $50, $125)  ;  READ  1ST  LINE 

7  LC=  1  ;  LINE  COUNTER 

IF  ( I OUT (4) . EQ. "TT" .AND . IOUT (5) . EQ . " AA " )  GO  TO  3  ;  NEU  RAOB  FORMAT 

GO  TO  4  ;  OLD  RAOB  FORMAT 

C 

C  NEU  RAOB  FORMAT 

3  IF  ( I0UTC6) .EQ. "  5 " . OR . I0UTC6) . EQ . "  6 " . OR . I0UTC6) . EQ . "  7". OR. 

1  I0UTC6) .EQ. "  8")  GO  TO  1  ;  TESTING  FOR  SINGLE  SPACE  AFT  TTAA 

K=-5  ;  DOUBLE  SPACE  AFTER  TTAA 

K 1  =-3 
K2=-2 
GO  TO  2 

1  K=-6  ;  SINGLE  SPACE  AFTER  TTAA 

K 1  =-3 
K2=-2 
GO  TO  2 
C 

C  OLD  RAOB  FORMAT 
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o  n 


4 


1 


DATE 

HOUR 


TESTING  IDT  8,  IHR  FOR  COR  VERSION 


10 


C 

5 


C 

C 


K=0 

IF  ( I0UT(6) .EQ. "  U".AND. I0UTC7) .EQ. "SI")  K=4 
K 1 =K/2 
K2=0 

IF  ( I0UTC9+K1) .EQ. "  5" .OR. I0UTC9+K1) .EQ. "  6" .OR. I0UTC9+K1) .EQ. "  ?". 

OR. I0UTC9+K1) .EQ. "  8")  GO  TO  2  ;  TESTING  FOR  SINGLE  SPACE  AFT  TTAA 

K=K- 1 

IDT- ITCVT  ( 18+K,2,$900)-50 
IHR=ITCVT  (20+K, 2, $900)  ; 

I VCHECK= I VCK ( I DATE, IHOUR, IDT, IHR) 

GO  TO  (5,  10,  1 16,  1 14),  IVCHECK 
CALL  PRVRF  CIER) 

IF  (IER.NE. 1)  GO  TO  114 
CALL  AFREAD  (3,IST,$102) 

CALL  AFREAD  (2, IOUT, $50, $125)  ; 

GO  TO  7 

TEST  FOR  MISSING  RAOB  10142  ETC. 

1 1 A= ITCVT  (30+K, 4, $900) 

I IB= ITCVT  (34+K, 1 , $900) 

1 1 1 A  =  ITCVT  (36+K, 3, $900) 

IF  ( I IA.EQ.5151 .AND. I IB.EQ.5. AND. 1 1 IA.EQ. 101)  GO  TO  110 
KKK= IOUT ( 1 1+K 1 )  ;  INDICATOR  FOR  LAST  LEVEL  OF  UND  DATA 

KKK2= IOUT ( 1 1+K2)  ;  2ND  INDICATOR  FOR  LAST  LEVEL  OF  UND  DATA 

KSS= 1  ;  SOME  UIND  DATA  AVAILABLE 

IF  (KKK.EQ. "0/" .OR.KKK.EQ. "2/" .0R.KKK2.EQ. "/  ")  KSS=0  ;  NO  UND  DATA  AVBL 
IF  (KSS.EQ.l)  KS - ITCVT (22+K, 1, $900)  ;  READ  INDICATOR  FOR  LAST  LVL  OF  UND 

BEGIN  READING  SFC  PRES  GRP 


READ  1ST  LINE  OF  PREVIOUS  VERSION 


K=29+K  j 
JC=-1 
KC=4  j 

LC  =  1  j 

GO  TO  19 


SET  CHARACTER  INDEX 
SET  LEVEL  INDEX 
SET  GROUP  INDEX 
LINE  COUNTER 


C 

18 


SET  GROUP  INDEX 
(2, IOUT, $50, $125)  ; 

LINE  COUNTER 
(KG. EQ. 1. AND.JC.LT. 12)  GO  TO  20 
(KG.EQ. 1 .AND. JC.EQ.  12)  GO  TO  26 


KC=0  ; 
CALL  AFREAD 
LC=LC+1  ; 
IF 
IF 


READ  2ND  AND  SUBSEQUENT  LINES 

;  READ  TEMP/DEUPT  GRP  NEXT 

;  READ  MAX  UND  GRP 


IF  (KG.EQ.2. AND.KSS.EQ. 1 .AND. ( I2.GE.KS.0R. IZ2.EQ.88) )  GO  TO  26 


C 

19 


80 

81 


READ  HEIGHT  GROUP 

KG  =  1 

KC-KC+1 

JC-JC+1 

GO  TO  81  ;  DELETE  THIS  LINE  FOR  TEST,  LINE  088 

NEXT  THREE  STATEMENTS  FOR  TEST  ONLY 

JD=JC- 1  ;  TEMPO  TEST  !!!!!!!!!!! 

IF  (JD.GE.0)  URITE  (IFD,80)  LC, KC, K, JC, 2 ( JD) , T( JD) , TD ( JD) , D ( JD) , S ( JD) 

FORMAT  (1H  ,4I3,F8.0,2F9. 1,2F8.0)  ;  TEMPO  TEST 

CONTINUE 

I Z  = I TC VT ( 1 +K , 1 , $900 )  ;  INDICATOR  FOR  PRES  LEVEL 

I Z2  = I TC VT ( 1 +K , 2 , $900 )  ;  2ND  INDICATOR  FOR  PRES  LEVEL 

:  NORMAL 

NORMAL,  66  ENCODED  INSTEAD  OF  77 
77  GROUP  NOT  REPORTED,  51515  READ 
:  SOME  LEVELS  MISG 

, OR. JC.EQ. 12))  GO  TO  34  ;  88  OR  77  GRP  ON  NXT  LINE 
FORMAT  ERROR 


IF 

IF 

IF 

IF 

IF 


( IZ2.EQ.  ISCJC) )  GO  TO  27 
(IZ2.EQ.66)  GO  TO  27 
(IZ2.EQ.51)  GO  TO  79 
(IZ2.EQ.88)  GO  TO  29 
( IZ2 . EQ . 00 . AND . (JC.EQ. 


GO  TO  112 


11-1 


(UAL 
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27 


C 

29 


33 


C 

34 


C 

C 

C 

20 


30 

31 

22 

23 


28 


C 

c 

c 

21 


26 


Z(JC)=FTCVT(3+K,3,$901)  ;  HEIGHT  (OR  SFC,  TROP,  MAX  UND  PRES) 

IF  (JC.EQ.  ll.AND.Z(JC) .EQ.999.)  GO  TO  69  ;  TROP  NOT  OBSERVED 

IF  (JC.EQ.  12. AND. Z( JC) .EQ.999.)  GO  TO  69  ;  MAX  UND  NOT  OBSERVED 

IF  (JC.EQ. 12)  GO  TO  21  ;  READ  MAX  UND  GRP 

IF  (KC.LT. 10)  GO  TO  20 
K>-6 

GO  TO  18 

DO  33  I=JC, 10  ;  SETTING  LVLS  MISG  (SHORT  RAOB) 

Z ( I ) =-99 . 9  ;  UILL  BE  CHANGED  TO  -999.,  STATEMENT  63 

T( I) *999. 

TD ( I ) =999 . 

D( I) =-99. 

S( I) =-99. 

JC=1 1 
GO  TO  27 

KG=3  ;  GO  TO  NEXT  LINE  TO  READ  83  OR  77  GRP  (UAL) 

K=0 

JC=JC-1 
GO  TO  18 

READ  TEMPERATURE/DEUPOINT  GROUP 


KG=2 

KC=KC+1 

KL=7+K 

KLL=(KL+5)/2 

KLM=KLL-2 

IF  ( IOUT(KLM) . EQ . "  /" .OR. IOUT(KLM) .EQ. "//")  GO  TO  22  ;  TEMP  MISG 

T( JC) =FTCVT (KL, 3, $90 1 )  ;  READ  TEMPERATURE 

IF  ( IOUT(KLL) .EQ. "/  " . OR . IOUT(KLL) . EQ . "//" )  GO  TO  30  ;  DEUPT  MISG 

TD ( JC) =FTCVT ( 10+K, 2, $90 1 )  ;  READ  DEUPOINT 

GO  TO  31 

TD ( JC) =999 .  ;  DEUPOINT  MISSING 

CALL  TEMPI  (T( JC) , TD ( JC) ) 

GO  TO  23 

T( JC) =999 .  ;  GOES  HERE,  IF  TEMP  AND  DEUPT  BOTH  MISG 

TD ( JC) =999 . 

CONTINUE 

IF  ( (KSS.EQ. 1 .AND. ( IZ . GE . KS . OR . IZ2.EQ.00)) .OR. IZ2 . EQ . 88 . OR . IZ2.EQ. 

1  99)  GO  TO  21  ;  TEST  UHETHER  OR  NOT  TO  READ  UND  GRP 

IF  (KC.EQ.  10)  GO  TO  28 


K=K+12 

D ( JC) =-99 .  ; 

UND 

MISG 

S( JC) =-99. 

GO  TO  19  ; 

SKIP 

UNDS 

K=0 

D ( JC) =-99. 

S ( JC) =-99 . 

GO  TO  18  ; 

SKIP 

UNDS 

READ  UIND  GROUP 

IF  (KC.LT. 10)  GO  TO  26 

K=- 12 

GO  TO  18 

KG=3 

KC=KC+1 

IF  (JC.EQ. 12. AND. KC.GT. 1)  K=K-6  ;  READING  77  UND  GRP 
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24 

25 


40 


79 

69 


C 

C 

71 


72 


76 

77 


78 

C 

C 

C 

C 

C 

73 


61 

60 


64 

63 

62 


KUOC13-HO/2+1 

IF  ( IOUT (KLK) . EQ . "//" )  GO  TO  24  ;  UIND  MISSING 

D(JC)-FTCVT(13+K,2,$901)  ;  READ  UND  DIR 

S(JC)=FTCVT(15+K,3,$901)  ;  READ  UND  SPEED 

CALL  UND  (D(JC) ,S(JC) ) 

GO  TO  25 

D(JC) =-99.  ;  UND  MISSING 

S  C  JO  =-99 . 

CONTINUE 

IF  (IZ2.EQ.77.0R. IZ2.EQ.66)  GO  TO  71  ;  MAX  UND  READ,  DO  UND  SHEAR  NXT 

IF  (KC.LT. 10)  GO  TO  40 

K=0 

GO  TO  18 
CONTINUE 
K=K+18 
GO  TO  19 

Z  ( JC)  =999 .  ;  MAX  UND  GROUP  NOT  REPORTED 

T (JO  =999 .  ;  GOES  HERE,  IF  TROP  OR  MAX  UND  NOT  OBSERVED 

TD  ( JO  =999. 

D  ( JC)  =-99 . 

S(JC) =-99. 

IF  (JC.EQ.12)  GO  TO  73  ;  FINISHED 

K=K+6 

GO  TO  19  ;  READ  77  GROUP 


READ  77  UIND  SHEAR  GROUP 
CONTINUE 

IF  (KC.LT. 10)  GO  TO  72 

CALL  AFREAD  (2, IOUT, $50, $125)  ;  READ  NXT  LINE  FOR  UND  SHEAR 

K=- 18 


IFOUR= ITCVT ( 19+K, 1 , $900) 

IF  (IFOUR.NE.4)  GO  TO  112 
KMK=(20+K)/2 

IF  ( IOUT(KMK) .NE. "4/")  GO  TO  76  ; 
T( JC) =999 .  ; 
GO  TO  77 

T( JC) =FTCVT (20+K, 2, $90 1 )  ;  LOUER 
IF  ( I0UT(KMK+2) . NE . "/  ")  GO  TO  78  ; 
TD ( JC) =999 .  ; 
GO  TO  73  ; 
TD ( JC) =FTCVT (22+K, 2, $90 1 )  ;  UPPER 


READ  LOUER  UND  SHEAR 
LOUER  UND  SHEAR  MISSING 

UND  SHEAR 

READ  UPPER  UND  SHEAR 
UPPER  UND  SHEAR  MISSING 
FINISHED 
UND  SHEAR 


SECONDARY  UND  MAXIMUM,  IF  ANY, (2ND  77  OR  66  GROUP)  IS  NOT  DECODED 


DECODE  PRESSURE/HEIGHT  VALUES:  Z(0)/Z(1) _ Z(10) 


IF  (Z (0) .LT. 100.)  Z(0) =Z(0)+1000.  ;  SFC  PRES 

IF  (Z ( 1 ) .LE.500.)  GO  TO  60 

Z ( 1 ) =- (Z ( 1 ) -500 . )  ;  1000MB  LEVEL  BLO  SEA  LEVEL 

URITE  ( IFD, 6 1 )  (IST(I), 1=4,5), Z ( 1 ) 

FORMAT  ( " < 15 >< 12>",3X,2A2, "  1000MB  LVL  BLO  SEA  LEVEL,  Z ( 1 )  =  ",F5.0) 
Z (2) =Z (2) +1000 .  ;  850MB 

IF  (Z (3) .GT.500. )  GO  TO  64 
Z  (3)  =Z (3) +3000 . 

GO  TO  63 

Z (3) =Z (3) +2000 .  ;  700MB 

DO  62  1=4, 10 

Z(I)=Z(I)*10.  ;  500  TO  100  MB 

DO  74  1=7,  10 

IF  (Z ( I ) .EQ.-999.)  GO  TO  75  ;  LEVELS  MISSING 
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74 

75 


250  TO  100  MB 


C 

c 

900 

65 

901 

66 

50 

51 

100 

101 

102 

103 

125 

126 

110 

111 

1 12 

1 13 

1 14 

1 15 

1 16 
1 17 


Z(  I)  =Z(  D  +  10000. 
CONTINUE 
PTROP-Z(ll) 
RETURN 


ERROR  RETURNS 

URITE  ( IFD, 65)  ( IST( I ) , I =4,5) 

FORMAT  ( "< 15X 12>",3X,2A2, "  ERROR  IN  ITCVT  -  DECOM") 

RETURN  Q 

URITE  (IFD, 66)  ( IST( I) , 1=4,5) 

FORMAT  ( " < 1 5 >< 1 2 > " 3X, 2A2 , "  ERROR  IN  FTCVT  -  DECOM") 

RETURN  Q 

URITE  (IFD, 51)  (IST(I), 1=4,5) 

FORMAT  ( "< 15>< 12> ” , 3X, 2A2, "  AFREAD  ERROR  50  -  DECOM") 

RETURN  Q 

URITE  (IFD, 101)  (IST(I), 1=4,5) 

FORMAT  ( "< 15X 12> " , 3X, 2A2, "  AFREAD  ERROR  100  -  DECOM") 

RETURN  Q 

URITE  (IFD, 103)  (IST(I), 1=4,5) 

FORMAT  ( " < 1 5 >< 1 2 > " , 3X, 2 A2 , "  AFREAD  ERROR  102  -  DECOM") 

RETURN  Q 

URITE  (IFD, 126)  ( IST( I) , I -4,5) 

FORMAT  ( "< 15>< 12>",3X,2A2, "  AFREAD  ERROR  125  -  DECOM") 

RETURN  Q 

URITE  (IFD, 111)  (IST(I), 1=4,5) 

FORMAT  ( "< 15>< 12> " , 3X,2A2, "  STATION  MISSING  -  DECOM") 

RETURN  Q 

URITE  (IFD, 113)  (IST(I), 1-4,5), IS(JC) 

FORMAT  ( "< 15>< 12> " , 3X, 2A2, "  FORMAT  ERROR  AT  LEVEL  ",I2,"  -  DECOM") 
RETURN  Q 

URITE  (IFD, 115)  (IST(I), 1=4,5) 

FORMAT  ( "< 15X 12>",3X,2A2, "  DESIRED  VERSION  NOT  FOUND  -  DECOM") 
RETURN  Q 

URITE  (IFD, 117)  (IST(I), 1=4,5) 

FORMAT  ( " <  1 5 ><  1 2 > " , 3X, 2 A2 ,  "  NEIJ  RAOB  NOT  AVBL  -  DECOM") 

RETURN  Q 
END 

* 


C 

C 

c 

c 

c 

c 

c 

c 


1 


2 


* 

FUNCTION  I VCK  ( IDATE, IHOUR, IDT, IHR) 

CHECKS  DATE/TIME  GROUP  TO  GET  DESIRED  VERSION 

IDATE, IHOUR. . .DATE/HOUR  UANTED .  IDT, IHR ...  DATE/HOUR  OF  CURRENT  VERSION 
OUTPUT  IS  AN  INTEGER  UITH  VALUE  1  TO  4: 

I VCK  =  1  CURRENT  VERSION  IS  UANTED 

2  PREVIOUS  VERSION  IS  UANTED 

3  NEU  VERSION  IS  NOT  AVAILABLE 

4  VERSION  UANTED  IS  TOO  FAR  BACK,  CANNOT  BE  RETRIEVED 
DESIGNED  TO  RETRIEVE  VERSIONS  UP  TO  ABOUT  10  DAYS  IN  THE  PAST. 

IDTCHECK= IDATE- IDT 
IF  ( IDTCHECK)  1,3,2 
I VCK =2 

IF  (IDTCHECK.LT. -10)  I VCK =4 
IF  (IDTCHECK.LT. -20)  IVCK=3 
RETURN 
IVCK=2 

IF  (IDTCHECK.LT. 20)  IVCK=4 
IF  ( IDTCHECK.LT. 10)  IVCK=3 
RETURN 
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3  IHRCHECK= IHOUR- IHR 
IF  ( IHRCHECK)  4,5,6 

4  I VCK=2 
RETURN 

5  IVCK-1 
RETURN 

6  IVCK=3 
RETURN 
END 

* 


* 

SUBROUTINE  UND  (D,S) 

C  UIND  DECODE... D  =  DIRECTION  S=  SPEED 
IF  (S.LT.500.)  GO  TO  1 
D=D*10.+5. 

S=S-500. 

RETURN 
1  D=D*10 . 

RETURN 

END 

>K 


* 

SUBROUTINE  HEIGHT  (ZZ, PRES, HGT, Q) 

C  GIVES  HGT  OF  PRES  SFC  ACCORDING  TO  HEIGHTS  OF  STANDARD  LVLS  IN  "ZZ"  ARRAY 
INTEGER  Q 

DIMENSION  ZZ (0 : 12) 

COMMON/PS/SP ( 10) 

DATA  SP/1000., 850., 700., 500., 400., 300., 250., 200., 150., 100./ 

DO  1  1=1,10 
IF  (PRES-SP ( I ) )  1,2,3 

1  CONTINUE 

1=1-1  ;  "I"  IS  INCREASED  TO  11,  UHEN  "DO  1"  LOOP  IS  FINISHED 

IF  ((SP( 10)-PRES) .LE.50.)  GO  TO  3  ;  EXTRAPOLATE  UPUARD 

RETURN  Q  ;  PRES  IS  NOT  UITHIN  RANGE 

2  HGT =ZZ ( I )  ;  PRES  IS  A  STANDARD  PRESSURE  SFC 

RETURN 

3  IF  (I.EQ.l)  1=1+1 

SPC=SP( I- 1) -PRES 

IF  (SPC.LT.-100. )  RETURN  Q  ;  IF  PRES  MORE  THAN  1100MB,  DON'T  EXTRAPOLATE 
IF  (ZZCI) .EQ.-999. . AND . SPC . GT. 50 . )  RETURN  Q  ;  50MB  LIMIT  ON  UPUARD  EXTRAPOLATION 
IF  (ZZCI-1) .EQ.-999.)  RETURN  Q  ;  CANNOT  CONTINUE,  LUR  LVL  MISG 
IF  CZZCI) .EQ.-999.)  1=1-1  ;  EXTRAPOLATES  UPUARD  IF  UITHIN  50MB 

HGT =ZZ ( I ) +(ZZ ( I- 1 ) -ZZ ( I ) ) /ALOG (SP ( I- 1 ) /SP ( I ) ) *ALOG  CPRES/SP ( I ) ) 

RETURN 

END 

* 


* 

FUNCTION  JREAL  (R) 

C  ROUNDS  REAL  "R"  TO  INTEGER  VALUE 
RA=ABS (R) 

JREAL =RA  ;  TRUNCATES  POSITIVE  R  TO  INTEGER 

RD=RA-JREAL  ;  DECIMAL  PORTION 
IF  CRD.GE..5)  JREAL=JREAL+1 

IF  (R.LT.0.)  JREAL=-JREAL  ;  CHANGE  TO  ORIGINAL  SIGN 
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RETURN 

END 

* 


* 

FUNCTION  FTCV(DAT,Q) 

C 

C  THIS  FUNCTION  IS  FOR  USE  IN  READING  NUMERICAL  DATA  INPUT  BV  SWITCHES 
C  ASCII  CHARACTERS  IN  "DAT"  ARE  UNPACKED,  SCANNED,  AND  INTERPRETED 
C  AS  REAL  NUMBERS.  IF  NO  DECIMAL  POINT  IS  DETECTED,  IT  IS  ASSUMED 

C  TO  FOLLOW  THE  LAST  NUMERAL  IN  THE  FIELD.  THE  SCAN  BEGINS 

C  WITH  CHARACTER  IBGN.  N  CHARACTERS  ARE  SCANNED. 

C  ABNORMAL  RETURN  TO  STATEMENT  ~Q~. 

C  THIS  IS  A  MODIFICATION  OF  FUNCTION  FLTCVT  IN  AFREAD.LB 
C 

DIMENSION  IOUTUC20) 

INTEGER  Q, DAT (10) 

LOGICAL  NEG 
IBGN=1 

CALL  UNPACK(DAT,20, IOUTU) 

C 

C  DETERMINE  NUMBER  OF  CHARACTERS  TO  READ 
N=0 

DO  1  1=1,20 

IF  (IOUTUCI) .EQ.0)  GO  TO  2 

1  N=N+1 
C 

2  CONTINUE 
FTCV=0 . 

NEG=. FALSE. 

IEND=IBGN+N-1 


100 

IF  ( IOUTUC IEND) .NE. 

32) 

GO 

H 

O 

IF  ( IEND. EQ. IBGN)  RETURN 

IEND= IEND- 1 

GO  TO  100 

200 

DO  250  I  =  IBGN, IEND 
IF  (IOUTUCI) .NE.32) 

GO 

TO 

300 

250 

CONTINUE 

RETURN 

300 

IF  (IOUTUCI) .EQ.43) 

GO 

TO 

400 

IF  ( IOUTUC I) .NE. 45) 

GO 

TO 

500 

NEG= . TRUE . 

400  1=1+1 

500  J=I 

DO  600  I =J, IEND 

IF  ( IOUTU ( I ) . EQ . 32)  IOUTUCI)=48 
IF  (IOUTU(I) .LT.48.OR. IOUTUCI) .GT.57)  GO  TO  700 
FTCV=FTC V* 1 0+ I OUTU ( I ) -48 
600  CONTINUE 

IF  CNEG)  FTCV=-FTCV 
RETURN 

700  IF  (IOUTUCI) .NE. 46)  GO  TO  800 

J-I  +  l 
D I V= 10 . 

DO  750  I=J, IEND 

IF  (IOUTUCI) .EQ.32)  IOUTU(I)=48 

IF  (IOUTU(I) .LT. 48. OR. IOUTUCI) .GT.57)  GO  TO  800 

FTCV=FTCV+( IOUTU ( I ) -48) /D I V 

DIV»DIV*10. 
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750 


CONTINUE 

IF  (NEG)  FTCV— FTCV 
RETURN 
800  RETURN  Q 
END 

* 


* 

OVERLAY  0V2 
SUBROUTINE  TPB 

C  COMPUTATION  OF  POTENTIAL  UNSTABLE  LYRS  AND  OUTPUT  FOR  URKTPB 

C0MM0N/S/JST(5),KDATE(3), IHOUR, JNO, JJNO, P (0:50), TS (0:50), TSD (0:50) 
COMMON/G/PP(0:20),ET(20),TU(0:50),DP,EFF,KMOD,KK 
COMMON/GG/NJ,PPB( 15) ,PPT( 15) ,DELPP( 15) ,DTUDP( 15) ,DPB( 15) ,DPT( 15) , 

1  PTMAX, PBMAX, TULAPSE, DMAX 

THETA (T, P2, P 1 ) =T*(P2/P 1 ) **.2857142  ;  DRY  ADIABATIC  (T,P1)  TO  (THETA, P2) 

C 

C  COMPUTE  UET  BULB  POTENTIAL  TEMP  AT  ALL  SGFNT  LEVELS  ABV  SFC 
DO  78  I  =0, JNO 

TC-TCONOF(TS(I),TSD(I))  ;  CONDENSATION  TEMPERATURE 
TH=THETA(TS( I) +273. 16, 1000. , P(  I) )-273. 16  ;  POT  TEMP  DEG  C 

UTH=UOBF (TH) 

UTC=UOBF (TO 

78  TU( I) =TH-UTH+UTC  ;  UET  BULB  POT  TEMP  -  DEG  C 
C 

CALL  PULYR  ;  DETERMINES  POTENTIAL  (CONVECTIVE)  UNSTABLE  LAYERS 
URITE  (21,1)  ( JST ( I ) , I =4,5) , (KDATE ( I ) , 1*1,3), I HOUR 

1  FORMAT  ( 12X, “  POTENTIAL  (CONVECTIVE)  UNSTABLE  LAYERS  FOR  ■ 

1  , 2A2, 4X,  12,  12,  12, 3X,  12,  "2") 

URITE  (21,2) 

2  FORMAT  ( "< 15>< 12> " , 3X, "P1",8X, "P2",8X, "DP",4X, "TULAPSE " , 6X, "DP1",7X, nDP2") 
M=NJ+1 

DO  B  1=1, N J 
J  =M- 1 

URITE  (21,7)  PPB ( J) , PPT ( J) , DELPP( J) , DTUDP ( J) , DPB ( J) , DPT( J) 

7  FORMAT  ( "< 15>< 12> " , 1X,F5 . 0, 2F 10. 0, F 10 . 1 , 2F 10 . 0) 

8  CONTINUE 
URITE  (21,5) 

5  FORMAT  ( "<  15>< 12> " )  ;  BLANK  LINE 

URITE  (21,77) 

77  FORMAT  ("< 15X 12> " , "S IGN IF ICANT  LEVELS " , 

1  /"<  15><  12> " ,  4X,  "P",  9X,  "T" ,  9X,  11 TD " ,  8X,  "TU  (UET  BULB  POTENTIAL  TEMP)") 

M=JNO 

DO  79  1=0, M 
J=M- 1 

URITE  (21,80)  P(J),TS(J),TSD(J),TU(J) 

80  FORMAT  ( "< 15>< 12> " , IX, F5 . 0, 3F 10 . 1 ) 

79  CONTINUE 

URITE  (21,5)  ;  ENDING  UITH  BLANK  LINE 

RETURN 

END 

* 


* 

OVERLAY  0V3 

SUBROUTINE  TPA(JEFF,EL1,RLI,RKI,RUI, IDECOM) 

C  OUTPUT  FOR  SINGLE  STATION  RAOB  ANALYSIS  FOR  URKTPA 

C0MM0N/S/JST(5) , KDATE (3) , IHOUR, JNO, JJNO,P(0:50) ,TS(0:50) ,TSD(0:50) 
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54 


71 


45 

72 

46 

73 


5 

4 

C 


50 


27 

51 

26 


56 


47 

57 


48 

59 


52 

53 

100 


COMMON/G/PP ( 0 : 20 ) , ET ( 20 ) , TU ( 0 : 50 ) , DP , EFF , KMOD , KK 
COMMON/GG/NJ,PPB( 15) ,PPT( 15) ,DELPP( 15) ,DTUDP( 15) ,DPB( 15) ,DPT( 15) , 

1  PTMAX, PBMAX, TULAPSE , DMAX 

COMMON/T/RLCL, RLFC, EL, B2, B2P, B2N, IALL,B1,B1P,B1N,EX 
COMMON/CCL/PCCL, ETCCL, TS0, TSD0, L, TSCCL, TCCL, TDCCL, UAVG 
COMMON/TT/PT(0 : 50) , TST(0 : 50) , TSDTC0: 50) 

COMMON/V/JNOM, PX 

URITE  (20,54)  (JST(I), 1-4,5), (KDATE(I), 1-1,3), IHOUR 

FORMAT  (1H  , "RAOB  ANALYSIS  FOR  • ,2A2,4X, 12, V»,I2, "/", I2,3X, 12, "Z", 

1  1 IX, "UNITS  :  J/KG  X  10") 

IF  (JEFF.GE.  100)  GO  TO  45 
URITE  (20,71)  EFF, JEFF 

FORMAT  ("<15><12>",2X, "ASSUMED  EFF  -  ",F4.0,"  PERCENT  ENTRAINMENT 
1  PER  500MB  ASCENT,  FOR  Ell,  EI2  &  EL", 12) 

GO  TO  46 

URITE  (20,72)  EFF, JEFF 

FORMAT  ("< 15X 12>",2X, "ASSUMED  EFF  =  ",F4.0,"  PERCENT  ENTRAINMENT 
1  PER  500MB  ASCENT,  FOR  Ell,  EI2  8.  EL",  13) 

URITE  (20,73) 

FORMAT  ("<15X12>",2X,  "ASSUMED  EFF  =  0.  PERCENT  ENTRAINMENT 

1  PER  500MB  ASCENT,  FOR  EL") 

URITE  (20,5) 

FORMAT  ( "< 15X 12>" )  ;  PUTTING  IN  BLANK  LINE 

URITE  (20,4)  P (0) , P ( JNO) , PT(0) , PX 

FORMAT  ( "< 15X 12> " , "P0  =  ",F5.0,4X, "PTOP  *  ",F5.0,4X, "PMAX  (MAX  INSTABILITY) 
1  F5.0,4X, "PX  =  " , F5 . 0) 


IF  ( IDECOM. EQ . 0)  GO  TO  27 
URITE  (20,50)  EL,EL1 ,RLCL,RLFC 

FORMAT  ( "< 15X 12>“, "EL  =  ",F5.0,"  MB  (",F4.0,"  HND  FT)  LCL  =  ", 

1  F5.0,4X, "LFC  =  ",F5.0/"<15><12>", "BASED  ON  PARCEL  MVG  FM  LVL  -PMAX-") 

GO  TO  26 

URITE  (20,51)  EL, EL  1 ,RLCL,RLFC 

FORMAT  ( "< 15X 12>", "EL  =  ",F5.0,"  MB  (",F4.0,"E  HND  FT)  LCL  -  ", 

1  F5.0,4X, "LFC  =  ",F5.0/"<15><12>", "BASED  ON  PARCEL  MVG  FM  LVL  -PMAX-") 

CONTINUE 
URITE  (20,5) 

IF  (JEFF.GE.  100)  GO  TO  47 
URITE  (20,56)  B2, JEFF, B1,B2P,B1P,B2N, BIN 
FORMAT  ( "< 15X 12>", "EI2  =  ", F7 . 0, 2X, "ENERGY  PMAX  TO  EL 

1  "ENERGY  PMAX  TO  PX"/ 

2  "< 15X 12>", "EI2P  =  ",F7.0,2X, "POSITIVE  PART", 9X, "El  IP  = 

3  "< 15X 12>", "EI2N  -  ",F7.0,2X, "NEGATIVE  PART" , 9X, "E I  IN  = 

GO  TO  43 

URITE  (20,57)  B2, JEFF, B1,B2P,B1P,B2N, BIN 
FORMAT  ( "< 15X 12>", "EI2  =  ", F7 . 0, 2X, "ENERGY  PMAX  TO  EL 

1  "ENERGY  PMAX  TO  PX"/ 

2  "< 15X 12>", "EI2P  =  ",F7.0,2X, "POSITIVE  PART" , 9X, "E I  IP  = 

3  "<  15X  12>", "EI2N  =  ",F7.0,2X, "NEGATIVE  PART" , 9X, "E I  IN  = 

URITE  (20,5) 

URITE  (20,59) 

FORMAT  ("<15X12>",  "PI", 9X,  "P2 ", 9X,  "ENERGY  GAINED  (LOST)  IN  LAYER") 

KK 1 =KK- 1 
DO  53  1=1, KK 1 
J  =  I- 1 

URITE  (20,52)  PP ( J) , PP ( I ) , ET( I ) 

FORMAT  ("< 15X 12> " ,F5. 0,5X,F5 .0, 5X,F7. 0) 

CONTINUE 

URITE  (20,100)  EX 
FORMAT  ( "<  15X  12> " ,  "EX  -  ", 


",  12, 3X, "Ell  »  ",F7.0,2X, 

",F7.0,2X, "POSITIVE  PART"/ 
",F7.0,2X, "NEGATIVE  PART") 

",I3,2X, "Ell  =  " , F7 . 0, 2X, 

",F7.0,2X, "POSITIVE  PART"/ 
",F7.0,2X, "NEGATIVE  PART") 


F7.0) 

-43- 


URITE  (20,5) 

URITE  (20,81)  RL I , RK I , RUI 

81  FORMAT  ( "< 15>< 12>", "LI  *  \F4.0,4X, "KI  -  ",F4.0,4X, "SUI  -  ",F4.0) 

URITE  (20,5) 

TSCCLF 3 1 . 8*TSCCL+32 .  ;  CONV  TEMP  IN  DEG  F 

URITE  (20,93)  PCCL,ETCCL,TSCCL, TSCCLF, UAVG 
93  FORMAT  ( "< 15X 12>", "CCL  =  " , F5 . 0, 2X, "ETCCL  =  fl,F6.0,2X, "CONV  TEMP  ®  n 

1  , F5 . 1 ,  "  (",F5. 1, "F  )  UAVG  =  ",F5.2,"  G/KG") 

URITE  (20,5) 

IF  (DMAX.GT.0.)  GO  TO  9 
URITE  (20,10) 

10  FORMAT  ( "< 15>< 12> " , "DEEPEST  POT.  UNSTABLE  LYR  :  NONE") 

GO  TO  11 

9  URITE  (20,12)  PBMAX, PTMAX, TULAPSE 

12  FORMAT  ("<15><12>", "DEEPEST  POT.  UNSTABLE  LYR  :  ",F5.0,"  -  ",F5.0, 

1  "MB,  TULAPSE  =  ",F5.1,"  SEE  URKTPB " ) 

11  URITE  (20,5)  ;  ENDING  UITH  A  BLANK  LINE 

RETURN 

END 

* 


* 

SUBROUTINE  PULYR 

C  COMPUTATION  OF  POTENTIAL  (CONVECTIVE)  UNSTABLE  LAYERS,  UITH  LAPSE  RATE 

C  OF  UET  BULB  POTENTIAL  TEMPERATURE  AND  AMOUNT  OF  LIFT  REQUIRED  FOR  SATURATION 

C0MM0N/S/JST(5) , KDATE (3) , I HOUR, JNO, JJNO,P (0:50) ,TS (0:50) ,TSD (0:50) 
COMMON/G/PP (0 : 20) , ET(20) , TU(0 : 50) , DP, EFF, KMOD, KK 
COMMON/GG/NJ, PPB ( 15) , PPT ( 15) , DELPP ( 15) , DTUDP ( 15) , DPB ( 15) , DPT( 15) , 

1  PTMAX, PBMAX, TULAPSE, DMAX 
DMAX=0 
NJ=0 
IT®- 1 
MK=0 

JNNO=JNO- 1 
DO  1  I =0, JNNO 

IF  ( ( TU ( I ) -TU ( I + 1 ) ) . LE . 0 . )  GO  TO  2  ;  GOES  TO  2,  IF  STABLE 

GO  TO  4 

2  IF  (MK.EQ.0)  GO  TO  1  ;  MK=0  INITIALLY,  OR  IF  PREVIOUS  LYR  STABLE 

GO  TO  3  ;  GOES  TO  3,  UHEN  TOP  OF  UNSTABLE  LYRS  IS  REACHED 

C  DETERMINING  INDICES  OF  UNSTABLE  LYR,  IT  =  TOP,  IB  =  BOTTOM 

4  IF  (I.GT.IT)  I B  =  I 
IT® 1+1 

MK  =  1 
GO  TO  1 

3  NJ=NJ+1 

PPT (NJ) =P ( IT) 

PPB(NJ) =P( IB) 

DELPP (NJ) =P( IB)-P( IT) 

DTUDP (NJ) =(TU( IB)-TU( IT) ) /DELPP (NJ) *100. 

IF(DELPP(NJ) .LE.DMAX)  GO  TO  5 
DMAX=DELPP (NJ) 

TULAPSE=DTUDP (NJ) 

PTMAX=PPT (NJ) 

PBMAX=PPB (NJ) 

5  TC=TCONOF  (TS ( IB) , TSD ( IB) )  ;  CONDENSATION  TEMPERATURE 

PC=P ( IB) *( (TC+273 . 16)/(TS( IB) +273. 16) )**( 1 ./. 2857 142)  ;  COND  PRESSURE 
DPB (NJ) =P ( IB) -PC  ;  AMT  OF  LIFT  REQUIRED  FOR  BOTTOM  SATURATION 
TC=TCONOF  (TS ( IT) , TSD ( IT) ) 

PC=P(IT)*(  (TC+273 .  16)/(TS(  IT) +273. 16)  )**(  1 2857 142) 
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n  n 


AMT  OF  LIFT  REQUIRED  FOR  TOP  SATURATION 


DPT(NJ) *PC IT) -PC  ; 

MK=0 

1  CONTINUE 

RETURN 
END 

# 


* 

OVERLAY  OV0 
PARAMETER  MRAOB-50 

' NRAOB'  MUST  AGREE  UITH  SAME  PARAMETER  IN  RANP  AND  GPT! ! ! 

THIS  SUBROUTINE  FINDS  X  AND  Y  COORDINATES  FOR  PLOTTING  ON  MAP 
C  BACKGROUND  2  BY  SEARCHING  STATION  DIRECTORY  FILE. 

C  THREE  LETTER  STATION  IDENTIFIER  (PACKED)  MUST  BE  SUPPLIED  IN  ARRAY  '1ST'. 
SUBROUTINE  STLOC  (N, I XX, I YY, 1ST) 

DIMENSION  IXX(NRAOB) , IYY(NRAOB) , I ST (NRAOB, 2) , JST(3) , IB(3) , IAD(2), 

1  IC1(14),  IC2C14),  IC3C14) 

IFLDP= 1 
IFLD=6 
I  AD ( 1 ) =0 
I AD (2) =0 

JST (3) =20040K  ;  DOUBLE  SPACE 

CALL  GCHN  (ICHN, IER) 

CALL  OPENR  ( ICHN, "STD IR . MS " , 0. IER) 

IF  (IER.NE.l)  TYPE  "ERROR  IN  OPENING  'STDIR.MS'  -  STLOC,  IER  =  ",IER 
CALL  RDS  ( ICHN,  IB, 6,  IER)  ;  READ  FIRST  3  UORDS  FROM  FILE 

IF  (IER.NE.l)  TYPE  "READ  ERROR  IN  'STDIR.MS'  -  STLOC,  IER  =  ",IER 
DO  4  I-1,N 
JST ( 1 ) = I ST ( I , 1) 

JST (2) = IST( I , 2)  ;  STN  IDENTIFIER,  USED  TO  SEARCH  'STDIR.MS' 

CALL  BNSCH ( ICHN,  IB ( 1 ) ,  IB (2) , IB (3) , IFLDP, IFLD,JST, I AD, IC1, IC2, IC3, IC) 
IF  (IC.EQ.0)  GO  TO  5 
GO  TO  (1,2,3),  IC 

1  IXX( I ) =2*IC 1(8) 

I YY ( I ) =2*IC 1 (9) 

GO  TO  4 

2  IXX( I ) =2*IC2 (8) 

IYY(  I)  =2>«IC2 (9) 

GO  TO  4 

3  I XX ( I ) =2*IC3 (8) 

I YY ( I ) =2*IC3 (9) 

GO  TO  4 

5  IXX(I)=0 

IYY( I ) =0  ;  X  8.  Y  COORDINATES  ZERO,  IF  STATION  NOT  FOUND 

URITE  (10,6)  (JST(J), J-1,3) 

6  FORMAT  (1H  ,3A2,"N0T  FOUND  IN  'STDIR.MS'  FILE") 

4  CONTINUE 

CALL  KLOSE  (ICHN, IER) 

IF  (IER.NE.l)  TYPE  "CHANNEL  NOT  CLOSED  -  STLOC,  IER  =  MER 

RETURN 

END 

* 


>k 

OVERLAY  OV1 
PARAMETER  NRAOB=50 

C  PARAMETER  -NRAOB-  MUST  AGREE  UITH  SIMILAR  PARAMETER  IN  RANP 
SUBROUTINE  GPT (N, IXX, IYY, JB, JEL, 1ST, IHOUR, KDATE, JEFF) 
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1 

2 


1 


CONVERT 
PLOTTING 
5, IVOF) 


B 1  TO  ASCII 


C  THIS  VERSION  FOR  USE  ON  MAP  BACKGROUND  2 
C  THIS  SUBROUTINE  PLOTS  A  GRAPHIC  (EL/BI) 

C  INSERTS  ENTRAINMENT  RATE  INTO  HEADING  OF  GRAPHIC 

DIMENSION  IXXCNRAOB),  IVY(NRAOB) , JB(NRAOB) , JEL(NRAOB) , IST(NRA0B,2) 
,KDATE(3) 

DIMENSION  ISC(5),JS(3), ITC15) 

COMMON/TITLE/JT (12) 

DATA  JT/nEL/EIl  EFF  ;  FIRST  LINE  OF  TITLE 

MAP  =2 

DO  10  1=1, N 
IX= IXXC I ) 

IY-IYYCI) 

JDAT=JB(  I) 

IF  (JDAT. EQ. 999)  GO  TO  1 
CALL  ISCR C ISC, JDAT, - 1 )  ; 

I YOF  =  12  ;  Y  OFFSET  FOR 

CALL  TEXT  C ISC, IX, IY, 1,2, 

JDAT =JEL ( I ) 

CALL  ISCRC ISC, JDAT, +1)  ;  CONVERT 

CALL  TEXT  ( ISC,  IX,  I Y,  1 , 2, -40, IYOF)  ; 

ISC (2) =14  ;  STATION  SYMBOL,  CLEAR 

GO  TO  2 
ISC (2) =5 
ISCC 1) =22K 
ISC (3) =2  IK 
ISC (4) =0 
ISC (5) =0 

IF  (JB( I) .GT.0.AND. JBC I) .NE.999) 

CALL  TEXT  ( ISC, IX, I Y, 1 , 1 , 0, 0) 

JSC1)-ISTC I, 1) 

JS (2) = ISTC 1,2) 

JS (3) =0 

CALL  TEXT  ( JS,  IX, I Y, 1 , 1 , -7, - 10) 

10  CONTINUE 

CALL  MTITL ( IHOUR, KDATE,  IT) 

C  PRINT  TITLE  IN  LOWER  RIGHT  CORNER  OF 


ELI 


PLOT  B 1 

TO  ASCII 
PLOT  ELI 


MISSING  DATA 

START  SPECIAL  SYMBOLS 

END  SPECIAL  SYMBOLS 


ISC (2) =3  ;  STATION  SYMBOL,  OVERCAST 

PLOT  STATION  SYMBOL 


PLOT  STATION  ID 


MAKE  DATE/TIME 
GRAPHIC 


GRP  TITLE 


CALL  ISCRC  ISC, JEFF, -1)  ; 

DO  3  1=3,  12 
JTC I ) = ISC ( 1-7) 

CALL  TEXT  ( JT, 2600, 550, 3, 1 , 0, 0) 
CALL  TEXT  ( IT, 2600, 450, 3, 1 , 0, 0)  ; 
CALL  UTF ( "NMCGPHE IS " , "HMSGPH .01") 
RETURN 
END 

* 


CONVERT  ENTRAINMENT  RATE  TO  ASCII 


;  FIRST  LINE  OF  TITLE 
DATE/TIME  LINE  OF  TITLE 


* 

SUBROUTINE  ISCR  C ISC, JDAT, KSH IFT) 

C  CONVERTS  JDAT  TO  ASCII 

C  SET  KSH IFT  =  -1  FOR  SHIFT  LEFT,  +1  FOR  SHIFT  RIGHT 
DIMENSION  ISC (5) 

ISC  C 1 ) =32  ;  SPACE 

IF  CJDAT.LT.0)  ISC C 1 ) =45  ;  NEGATIVE  SIGN 

JDAT= I ABS ( JDAT)  ;  USE  ABSOLUTE  VALUE  OF  JDAT 
IF  CJDAT.LT. 1000)  GO  TO  2  ;  NORMAL 

JDAT=888  ;  388  DENOTES:  NUMBER  TOO  LARGE 

2  ISC (2) =JDAT/100  ;  HUNDREDS  DIGIT 

IS= JDAT- ISC (2) *100 
ISC (3) = IS/10  ;  TENS  DIGIT 
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O  CD 


ISC  C 4) *  IS- 10* I SC (3) 

IF  ( ISC (2)  . NE . 0)  GO  TO  3 
IF  CISCC3) .NE.0)  GO  TO  6 
IF  (KSHIFT.EQ. 1)  GO  TO  1 

C  CONVERT  1  DIGIT  NUMBER  TO  ASCII  AND  SHIFT  LEFT 
ISC  (2)  *  ISC  (4)  +48 
ISC (3) =32  ;  SPACE 

ISC (4) =32  ;  SPACE 

GO  TO  5 

C  CONVERT  1  DIGIT  NUMBER  TO  ASCII  AND  SHIFT  RIGHT 
1  ISC (4) = ISC  C 4) +48 

ISC (3) = ISC ( 1 )  ;  SHIFT  SIGN 

ISC ( 1 ) =32  ;  SPACE 

ISC (2) =32  ;  SPACE 

GO  TO  5 

IF  (KSHIFT.EQ. 1)  GO  TO  7 
CONVERT  2  DIGIT  NUMBER  TO  ASCII  AND  SHIFT  LEFT 
ISC  (2)  = ISC (3) +48 
ISC  (3)  =  ISC  (4)  +48 
ISC (4) =32  ;  SPACE 

GO  TO  5 

C  CONVERT  2  DIGIT  NUMBER  TO  ASCII  AND  SHIFT  RIGHT 
7  ISC (4) = ISC (4) +48 

ISC (3) = ISC (3) +48 
ISC (2) =  ISC ( 1 ) 

ISC  C 1) =32 
GO  TO  5 

C  CONVERT  3  DIGIT  NUMBER  TO  ASCII 
3  ISC  (2)  =  ISC  (2)  +48 

ISC  (3)  =  ISC  (3)  +48 
I SC ( 4) = I SC ( 4) +48 
5  CONTINUE 

ISC (5) =0  ; 

RETURN 
END 

* 


UNITS  DIGIT 

;  FINISHED,  3  DIGIT  NUMBER  IS  PLOTTED 
;  2  DIGIT  NUMBER  IS  PLOTTED 


SHIFT  SIGN 
SPACE 


SET  TO  ZERO  FOR  TEXT  SUBROUTINE 


SUBROUTINE  JSCR 
C  CONVERTS  POSITIVE  2 

C  IF  NEGATIVE  INTEGER 

C  THIS  SUBROUTINE  FOR 

DIMENSION  KS (2) 

IF  (KN.GE.0)  GO  TO  1 
KS  Cl) =57  ;  9 

KS (2) =57  ;  9 

URITE  (10,2)  KN 
2  FORMAT  (1H 

1  MISTAKE  IN 

RETURN 

1  CONTINUE 

KS1=KN/10 
KS ( 1 ) =KS 1+48 
KS (2) =KN- 10*KS 1+48 
IF  (KS ( 1 ) . EQ . 48)  KS ( 1 ) 
RETURN 
END 


* 

(KN,KS) 

DIGIT  INTEGER  TO  ASCII 
IS  ENTERED,  99  IS  RETURNED 

GETTING  ASCII  DATE/TIME  NUMBERS  FOR  PLOTTING 


NORMAL 


, "NEGATIVE  NUMBER,  KN  =  ",  14, " 
DATE/TIME  GROUP  OF  GRAPHIC") 


IN  SUBROUTINE  JSCR. 


>32 


TENS  DIGIT 

TENS  DIGIT  CONVERTED  TO  ASCII 
UNITS  DIGIT  CONVERTED  TO  ASCII 
;  SUBSTITUTE  SPACE  FOR  ASCII 


ZERO 


* 
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c 

c 


13 


c 


c 


c 

c 

c 


1 


2 


3 


4 


5 


6 


7 


8 


* 

SUBROUTINE  MTITL  ( IHOUR, KDATE, IT) 

THIS  SUBROUTINE  RETURNS  DATE/TIME  GROUP  "IT"  FOR  GRAPHIC  TITLE 
DIMENSION  KDATEC3), IT(15),KS(2) 

GET  ASCII  TIME 

ITC 1) =48  ;  0 

IT(2)=48  ;  0 

IF  (IHOUR.EQ.0)  GO  TO  13 
ITU) -49  ;  1 

1T(2) =50  ;  2 

ITC3) =90  ;  Z 

IT(4)«32  ;  SPACE 

IT(5)-32  ;  SPACE 

GET  ASCII  DATE 

CALL  JSCR  CKDATEC2) ,KS) 

IT(6) =KS ( 1 ) 

IT(7)=KS(2) 

ITC8) =32  ;  SPACE 

IT ( 12) =32  ;  SPACE 

GET  ASCII  YEAR 

CALL  JSCR  (KDATEC3) ,KS) 

IT(13)-KS(1) 

ITC 14) =KS (2) 

ITC 15) =0  ;  MUST  BE  ZERO  FOR  TEXT  SUBROUTINE 

GET  3  LETTER  MONTH  ABBREVIATION 


KGO=KDATE ( 1 ) 

GO  TO  (1,2, 3, 4, 5, 6, 7, 8, 9,  10,  11,  12)  KGO 


IT(9) =74 
ITC 10) =65 
ITC 11) =78 
GO  TO  14 
ITC9) =70 
ITC 10) =69 
ITC 11) =66 
GO  TO  14 
I T ( 9 ) =77 
ITC 10) =65 
ITC 1 1) =82 
GO  TO  14 
ITC9) =65 
ITC 10) =30 
ITC 11) =82 
GO  TO  14 
I T ( 9 ) =77 
ITC 10) =65 
ITC 11) =89 
GO  TO  14 
ITC9) =74 
ITC 10) =85 
ITC 1 1) =78 
GO  TO  14 
ITC9) =74 
ITC 10) =85 
ITC 1 1) =76 
GO  TO  14 
I T ( 9 ) =65 
ITC 10) =85 


JAN 


FEB 


MAR 


APR 


MAY 


JUN 


JUL 


AUG 
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ITC11W1 
GO  TO  14 

9  IT(9)-83  ;  SEP 

IT( 10) *69 
ITC1D-80 

GO  TO  14 

10  ITC9W9  ;  OCT 

IT ( 10) *67 
ITC1D-84 

GO  TO  14 

11  ITC9W8  ;  NOV 

IT C 10) =79 

ITC 11) =86 
GO  TO  14 

12  IT(9) =68  ;  DEC 

ITC 10) =69 

ITC 1 1 ) =67 
14  CONTINUE 

RETURN 
END 

* 


* 


FUNCTION  ITCVT C IBGN, N, Q) 

C 

C  THIS  FUNCTION  IS  USED  UITH  SUBROUTINE  AFREAD.  ASCII 
C  CHARACTERS  IN  THE  CURRENT  LINE  ARE  SCANNED  AND  INTERPRETED 

C  AS  INTEGERS.  THE  SCAN  BEGINS  UITH  CHARACTER  IBGN  AND  N 

C  CHARACTERS  ARE  SCANNED.  ABNORMAL  RETURN  TO  STATEMENT  -Q-. 
C  THIS  IS  A  MODIFICATION  OF  FUNCTION  INTCVT  IN  AFREAD.LB 
C 

COMMON/QARDQ/IOUTUC80) 

INTEGER  Q 
LOGICAL  NEG 
ITCVT=0 
NEG=. FALSE. 

IEND= IBGN+N- 1 

100  IF  C IOUTUC IEND) .NE.32)  GO  TO  200 
IF  C IEND. EQ.  IBGN)  RETURN 
IEND=  IEND- 1  ' 

GO  TO  100 

200  DO  250  I = IBGN, IEND 

IF  CIOUTUCI) .NE.32)  GO  TO  300 

250  CONTINUE 

RETURN 

300  IF  CIOUTUCI) .EQ. 43)  GO  TO  400 

IF  C IOUTUC I) .NE.45)  GO  TO  500 

NEG= . TRUE . 


400  1=1+1 

500  J=I 

DO  600  I=J,  IEND 

IF  C IOUTUC I) .EQ.32)  IOUTUC I) =48 
IF  CIOUTUCI) .LT. 48. OR. IOUTUCI) .GT. 57)  GO  TO  800 
I TCVT= I TCVT* 1 0+ 1 OUTU  C I ) -48 
600  CONTINUE 

IF  CNEG)  ITCVT=-ITCVT 
RETURN 

800  RETURN  Q 

END 
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FUNCTION  FTCVT C IBGN,N,Q) 


C 

c 

c 

c 

c 

c 

c 

c 

c 


100 

200 

250 

300 

400 

500 


600 

700 


750 


800 


THIS  FUNCTION  IS  USED  UITH  SUBROUTINE  AFREAD.  ASCII 
CHARACTERS  IN  THE  CURRENT  LINE  ARE  SCANNED  AND  INTERPRETED 
AS  REAL  NUMBERS.  IF  NO  DECIMAL  POINT  IS  DETECTED,  IT  IS  ASSUMED 
TO  FOLLOU  THE  LAST  NUMERAL  IN  THE  FIELD.  THE  SCAN  BEGINS 
UITH  CHARACTER  IBGN.  N  CHARACTERS  ARE  SCANNED. 

ABNORMAL  RETURN  TO  STATEMENT  -Q-. 

THIS  IS  A  MODIFICATION  OF  FUNCTION  FLTCVT  IN  AFREAD.LB 


COMMON/QARDQ/IOUTU (80) 
INTEGER  Q 
LOGICAL  NEG 
FTCVT =0 . 

NEG=. FALSE. 


IEND= IBGN+N- 1 

IF  ( IOUTU ( I END) . NE . 32)  GO  TO  200 
IF  (IEND.EQ. IBGN)  RETURN 
IEND  =  IEND- 1 
GO  TO  100 

DO  250  I = IBGN, IEND 

IF  ( IOUTU(I) .NE.32)  GO  TO  300 

CONTINUE 

RETURN 

IF  ( IOUTU ( I) .EQ.43)  GO  TO  400 
IF  ( IOUTU ( I) .NE.45)  GO  TO  500 
NEG =. TRUE. 

1  =  1  +  1 


J  =  I 

DO  600  I=J, IEND 

IF  (IOUTU ( I) .EQ.32)  IOUTU(I)=48 

IF  ( IOUTU( I) .LT.48.0R. IOUTU( I) .GT.57)  GO  TO  700 

FTCVT=FTCVT* 1 0+ I OUTU ( I ) -48 

CONTINUE 

IF  (NEG)  FTCVT=-FTCVT 
RETURN 

IF  ( IOUTU ( I) .NE.46)  GO  TO  800 


J=I  +  1 


D I V= 10 . 

DO  750  I=J, IEND 

IF  (IOUTU (I). EQ.32)  I0UTU(I)=48 

IF  ( IOUTU ( I ) . LT. 48 . OR . IOUTU ( I ) . GT. 57)  GO  TO  800 

FTCVT=FTCVT+( IOUTU ( I ) -48) /D IV 

DIV=DIV*10. 

CONTINUE 

IF  (NEG)  FTCVT =-FTCVT 

RETURN 

RETURN  Q 

END 


>k 


* 

FUNCTION  UOBF(T) 

COMPUTE  BY  DOUBLE  ASYMPTOTIC  APPROXIMATION 
CONSIDER  SEPARATELY  IF  .GT.  OR  .LE.  20  DEG. 


CENT.  FOR  ALL  TEMPS. . . THETU-THETA-UOBF (THETA ) -HJOBF  (TEMPCON) 

CENT.  FOR  ALL  TEMPS. . . THETM»THETA-UOBF (THETA )+UOBF( TEMP) 

X-T-20.0 
IF (X)  10,10,20 
10  CONTINUE 

CURVE  FIG  FOR  COOL  TEMPERATURE  RANGE 

POL - 1 . 000+X* (-8.841 6605E-3+X* (1.47141 43E-4+X*( -9 . 67 1 9890E-7 
1  +X*(-3 . 26072 17E-8+X*(-3 . 8598073E- 10) ) ) ) ) 

POL=POL*POL 

UOBF =15.  130/(POL*POL) 

RETURN 

20  CONTINUE 

CURVE  FIT  FOR  UARMER  TEMPERATURES 

POL- 1 . 000+X*(3 . 6 182989E-3+X*(-l . 3603273E-5+X*(4. 96 18922E-7 

1  +X*(-6. 1059365E-9+X*(3 . 940 155  IE- 1 1+X*(- 1 . 2588 129E- 13 

2  +X*( 1 . 6688280E- 16) )))))) 

POL=POL*POL 

UOBF  =29 . 930/(POL*POL)  +0 . 9600*X- 14. 800 

RETURN 

END 

* 


* 

FUNCTION  SATLFT  (THM,P) 

COMPUTES  TEMPERATURE  (DEG  C)  UHERE  THETA  MOIST  (DEG  C)  CROSSES  P  (MB) 
CONSIDER  THE  EXPONENTIAL  FOR  POTENTIAL  TEMPERATURE  AS  ROCP 
ROCP=0. 2857 1428 

IF ( ABS (P- 1000 . 0) -0 . 00 10)  100,  100.200 
100  SATLFT =THM 

RETURN 

200  PURP® (P/1000 . 0) **ROCP 

COMPUTE  TEMPERATURE  OF  DRY  ADIABATIC  LIFT  FOR  FIRST  GUESS 
TONE®  (THM+273 .  16)  *PURP-273 . 16 
CONSIDER  PSEUDO-AD  I ABAT,  EU1,  THROUGH  TONE  AT  P. 

COMPUTE  EONE=EUl-THM 

EONE  =UOBF ( TONE ) -UOBF ( THM) 

RATE® 1 .0 
GO  TO  330 
300  CONTINUE 

CONTRIBUTION  TO  ITERATION  IS  CHANGE  IN  T 
CORRESPONDING  TO  CHANGE  IN  E 

RATE  = ( TTUO-TONE ) / ( ETUO-EONE ) 

TONE=TTUO 
EONE-ETUO 
330  CONTINUE 

COMPUTE  ESTIMATED  SATLIFT,  TTUO 
TTUO  =TONE-EONE*R ATE 

CONSIDER  PSEUDO-AD  I ABAT,  EU2,  THROUGH  TTUO  AT  P. 

COMPUTE  ETU0=EU2-THM 

ETUO  = ( TTUO+273 . 16) /PURP-273 . 16 
ETUO =ETUO+UOBF ( TTUO ) -UOBF ( ETUO ) -THM 
CORRECTION  TO  TTUO  IS  EOR 
EOR=ETUO*RATE 

IF(ABS(EOR)-0. 1000)  400,400, 300 
400  SATLFT =TTUO-EOR 

RETURN 
END 

* 
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FUNCTION  TCONOF (TEMP, DEUPT) 

COMPUTES  CONDENSATION  TEMPERATURE  (DEGREES  CENT)  BY  LIFTING 
S-TEMP-DEUPT 

CONSIDER  TEMP  AND  DEUPT  TO  BE  LIKE  UNITS  (C  OR  K) 

T =TEMP 

IF( 100. -TEMP)  4,5,5 

4  T-TEMP-273. 16 

COMPUTE  CURVE  FIT  IN  MOST  EFFICIENT  MANNER 

5  DLT=S*( 1 .2 185+0. 00 1278*T+S*(-0. 002 190+1 1 . 73E-6*S-5 . 20E-6*T) ) 
TCONOF =T-DLT 

RETURN 

END 

* 


* 

FUNCTION  UMROF (P, TD) 

COMPUTE  MIXING  RATIO  (G/KG) ... DEUPO INT  (DEGREES  C  OR  K) .. .PRESSURE  (MB) 
T=TD 

IF  (100. -T)  3,4,4 

3  T =T-273 . 16 

CURVE  FIT  CORRECTION  FOR  NON- IDEAL  GAS 

4  X=0.0200*(T-12. 5+7500. 0/P) 

UFU= 1 . +0 . 0000045*P+0 . 00 1 40*X*X 

COMPUTE  ACCORDING  TO  STANDARD  FORMULA 
FUESU=UFU*VAPFU(T) 

UMROF  =62 1 . 97* ( FUESU/ ( P-FUESU) ) 

RETURN 

END 

* 


* 

FUNCTION  DPTOF(EU) 

COMPUTE  DEUPO INT,  DPT,  IN  DEGREES  C  GIVEN  UATER  VAPOR  PRESSURE  (MB) 

CREATE  TOLERANCE  TO  DEGREE  DESIRED 
TOL=0. 00010 

IF  (EU-0 . 2 1382876E-09)  20,20,30 
20  DPTOF =- 10000 . 

RETURN 

30  IF  (1013.0-EU)  20,100,100 

CREATE  GUESS  BY  INVERTING  TETEN-S  FORMULA 
100  X=AL0G(EU/6. 1078) 

BOT  = 17 . 269388-X 
DPTOF =( 237. 3*X)/B0T 
BOT=BOT*EU 
DELTM=0 . 

200  EDP=VAPFU( DPTOF) 

CORRECT  GUESS  BY  DERIVATIVE  OF  TEMPERATURE  UITH  RESPECT  TO  VAPOR  PRES. 
CALCULATED  FROM  INVERSE  OF  TETEN-S  FORMULA 
DTDE = ( DPTOF+237 . 3 ) /BOT 
DELT =DTDE*(EU-EDP) 

DPTOF =DPTOF+DELT 

CHECK  THAT  ITERATION  IS  NOT  IN  AN  ENDLESS  CYCLE,  A  RARE  SITUATION 
C  IF  NEEDED,  CHANGE  -TOL-  AND  EXIT 
DM=DELT-DELTM 

IF (ABS (DM) . GE . 1 . E-7)  GO  TO  10  ;  IF  DM  VERY  SMALL,  ITERATION  IS  ENDLESS 
TOL=ABS (DELT) 
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TYPE  "TOLERANCE  CTOL)  IN  DPTOF  CHANGED  TO  ",TOL,"  (NORMAL  TOL  - 
10  DELTM— DELT 

CHECK  TO  SEE  IF  ANSUER  CLOSE  ENOUGH,  IF  NOT  ITERATE  OVER  CORRECTION 
IF  (ABS (DELT) -TOL)  300,300,200 
CHANGE  SO  DEUPOINT  IS  ALUAYS  LESS  THAN  THE  TEMP. 

COMPATIBILITY  UITH  TOL  IS  FORCED 
300  DPTOF -DPTOF-TOL 

RETURN 
END 

* 


* 

FUNCTION  VAPFU(T) 

COMPUTE  SATURATION  VAPOR  PRESSURE  OVER  UATER,  VAPFU,  IN  MBS. 
CONSIDER  T( TEMPERATURE)  IN  DEGREES  C  OR  DEGREES  K. 


X“T 

IF  (100.0-X)  3,4,4 
3  X“X-273 . 16 

CURVE  FIT  FOR  RANGE  -50  <  T  <  100  DEGREES  C. 


POL  =  0.99999683  E-00  + 

1  X  *(0.78736169  E-04  + 

2  X  *(0.43884187  E-08  + 

3  X  *(0.21874425  E-12  + 

4  X  *(0 . 1 1 1 12018  E- 16  + 

POL=POL*POL 
POL“POL*POL 

VAPFU=6 . 1 07800/ (POL*POL) 

RETURN 

END 

* 


X  *(-0.90826951 
X  *(-0.61117958 
X  *(-0.29883885 
X  *(— 0 . 17892321 
X  *(-0.30994571 


E-02  + 

E-06  + 

E- 10  + 

E- 14  + 

E- 19) )))))))) 


* 

SUBROUTINE  BNSCH( ICHN,NREC,LREC, ISTAR, IFLDP, IFLD, ITEST, 

1  I AD, IC 1 , IC2,  IC3,  IC) 

C  BINARY  SEARCH  ROUTINE: 

C 

C  PROGRAMMER  -  RICH  THOMAS  SXB,ISL,SDO  11/79 
C 

C  ICHN=CHANNEL  UHICH  FILE  HAS  BEEN  OPENNED  TO 
C  NREC=NUMBER  OF  RECORDS 

C  LREC=LENGTH  OF  EACH  RECORD  (BYTES) 

C  ISTAR=BYTE  OF  FIRST  RECORD  (©“BEGINNING) 

C  IFLDP“UORD  POINTER  TO  FIELD  IN  RECORD 
C  IFLD“LENGTH  OF  FIELD  IN  BYTES 

C  I TEST =ARRAY  CONTAINING  TEST  FIELD 

C  I AD=RETURNED  TUO  UORD  ARRAY  CONTAINING  ADDRESS  ITEST  RECORD 
C  SHOULD  BEGIN  AT- 

C  IC“  1,2,3  IN  SECOND  UORD  INDICATING  RECORD  UAS  FOUND  AND 

C  IS  IN  ARRAY  IC1,IC2,  OR  IC3 

C  THOSE  THREE  ARRAYS  SHOULD  BE  DIMENSIONED  LREC/2  UORDS 
DIMENSION  ITEST ( 1 ) , IC 1 ( 1 ) , IC2 ( 1 ) , IC3 ( 1 ) , I AD (2) 

DIMENSION  I AD  1 (2) , IAD2(2), IAD3(2) 

DIMENSION  D 1 (2) , D2 (2) 

INTEGER  D 1 , D2 
IC=0 

IADl(l)-0 

I AD  1 (2) “ISTAR 

CALL  SPOSdCHN,  IAD1,  IER) 


.00010) " 
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CALL  ERROR ( IER, 'II') 

CALL  RDSCICHN, IC1, LREC, IER) 

CALL  ERROR ( IER, 'RDS  -  IC1') 

D2 ( 1 ) a0 
D2 (2) aLREC 

CALL  DSUB(D2,D2,  IAD1) 

CALL  DMPYCDl ,NREC,LREC) 

CALL  DSUB ( I AD2, D 1 , D2) 

CALL  SPOSCICHN, IAD2, IER) 

CALL  ERROR ( IER, '  12' ) 

CALL  RDS( ICHN, IC2,LREC, IER) 

CALL  ERROR (IER.' RDS- IC2') 

CALL  BCOMP ( IC 1 C IFLDP) , ITEST, IFLD, IER1) 
IFCIER1.GT. l)GO  TO  100 
CALL  BCOMP( IC2C IFLDP) , ITEST, IFLD, IER2) 
IF ( IER2 . NE . 2) GO  TO  125 
5  CALL  DSUB  CD  1 , I AD2,  IAD1) 

CALL  DDVD (INC, IR, D 1 , LREC) 

IF ( INC . GE . 32767) GO  TO  900 
IFCINC.LT. l)GO  TO  150 
INC-C INC-D/2+1 
CALL  DMPYCDl, INC, LREC) 

CALL  DADDCIAD3, IAD1,D1) 

CALL  SPOSC ICHN, IAD3, IER) 

CALL  ERRORCIER,' 15') 

CALL  RDSC ICHN, IC3, LREC, IER) 

CALL  ERROR ( IER, ' 16' ) 

CALL  BCOMPC IC3C IFLDP) , ITEST, IFLD, IER3) 
IF ( IER3.EQ. l)GO  TO  50 
IF C IER3.EQ.2)G0  TO  60 
IF ( IER3 . NE . 3) GO  TO  900 
I AD ( 1) =IAD3(  1) 

I AD  C  2 ) = I AD3 (2) 

IC=3 

RETURN 

50  IAD 1(1)- IAD3 ( 1 ) 

I AD  1 C  2 ) = I AD3 (2) 

GO  TO  5 

60  I AD2  C 1 )  =  I AD3 ( 1 ) 

I AD2 (2) = IAD3 (2) 

IF C INC . EQ . 1 ) GO  TO  150 
GO  TO  5 

100  I  AD ( 1 ) = I AD  1 ( 1 ) 

I  AD (2) = IAD  1(2) 

IF ( IER1 .NE.3)G0  TO  101 
IC-1 

IAD ( 1 )  =  IAD  1(1) 

I AD (2) = IAD 1 (2) 

101  RETURN 

125  D 1 ( 1 ) =0 

D 1 (2) =LREC 

CALL  DADD ( I AD, D 1 , IAD2) 

IF ( IER2 . NE . 3) GO  TO  126 
IAD ( 1 ) = IAD2 ( 1 ) 

I AD (2) = I AD2 (2) 

IC=2 

126  RETURN 

150  I AD ( 1 ) = I AD3 ( 1 ) 

IADC2) -IAD3C2) 

RETURN 


-54- 


900  CALL  ERROR ( IER3, ' IER3') 

IER-2 

CALL  ERROR ( IER, 'TOO  MANY  RECORDS  IN  FILE') 

STOP 

END 
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NOAA  SCIENTIFIC  AND  TECHNICAL  PUBLICATIONS 

The  National  Oceanic  and  Atmospheric  Administration  was  established  as  part  of  the  Department  of 
Commerce  on  October  3,  1970.  The  mission  responsibilities  of  NOAA  are  to  assess  the  socioeconomic  impact 
of  natural  and  technological  changes  in  the  environment  and  to  monitor  and  predict  the  state  of  the  solid  Earth, 
the  oceans  and  their  living  resources,  the  atmosphere,  and  the  space  environment  of  the  Earth. 

The  major  components  of  NOAA  regularly  produce  various  types  of  scientific  and  technical  informa¬ 
tion  in  the  following  kinds  of  publications: 

PROFESSIONAL  PAPERS  —  Important  definitive 
research  results,  major  techniques,  and  special  inves¬ 
tigations. 


CONTRACT  AND  GRANT  REPORTS  —  Reports 
prepared  by  contractors  or  grantees  under  NOAA 
sponsorship. 

ATLAS  —  Presentation  of  analyzed  data  generally 
in  the  form  of  maps  showing  distribution  of  rainfall, 
chemical  and  physical  conditions  of  oceans  and  at¬ 
mosphere,  distribution  of  fishes  and  marine  mam¬ 
mals,  ionospheric  conditions,  etc. 


TECHNICAL  SERVICE  PUBLICATIONS  —  Re¬ 
ports  containing  data,  observations,  instructions,  etc. 
A  partial  listing  includes  data  serials;  prediction  and 
outlook  periodicals;  technical  manuals,  training  pa¬ 
pers,  planning  reports,  and  information,  serials;  and 
miscellaneous  technical  publications. 

TECHNICAL  REPORTS  —  Journal  quality  with 
extensive  details,  mathematical  developments,  or  data 
listings. 

TECHNICAL  MEMORANDUMS  —  Reports  of 
preliminary,  partial,  or  negative  research  or  technol¬ 
ogy  results,  interim  instructions,  and  the  like. 


Information  on  availability  of  NOAA  publication*  can  bo  obtainod  from: 

ENVIRONMENTAL  SCIENCE  INFORMATION  CENTER  (D822) 
ENVIRONMENTAL  DATA  AND  INFORMATION  SERVICE 
NATIONAL  OCEANIC  AND  ATMOSPHERIC  ADMINISTRATION 
U.S.  DEPARTMENT  OF  COMMERCE 

6009  Executive  Boulevard 
Rockville,  MD  20852 
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RANP 

STABILITY  ANALYSIS  PLOT  PROGRAM 


PART  B:  PROGRAM  EXECUTION  AND  ERROR  CONDITION  (RANP) 

PROGRAM  NAME:  RANP 

PROGRAM  EXECUTION 

1.  To  run  program  for  a  single  station,  at  ADM  type: 

RUN:RANP/S  CCCSGLXXX 

2.  To  check  the  database  prior  to  running  program  for  raobs  in 
file  STNS1,  at  ADM  type: 

RUN: RANP/ C 

3.  To  run  program  for  list  of  raobs  in  file  STNS1,  at  ADM  type: 

RUN: RANP 

A  local  switch  "/E"  is  available  for  changing  the  entrainment  rate 
from  its  basic  value  of  60  percent;  it  may  be  added  to  the  end  of 
the  RUN  line  in  options  1  and  3  above.  However,  use  of  E  switch  is 
not  recommended. 

ERROR  CONDITIONS 


Error  condition  messages,  if  any,  are  output  to  the  dasher  or  ADM 
and  the  alert  light  is  turned  on  at  the  ADM. 


B-l 


AFOS  Products: 


ID 

ACTION 

COMMENTS 

CCCSGLXXX 

Input 

List  from  file  STNS1  or  specified 
in  RUN  line. 

CCCMANXXX 

Input 

Not  necessary,  but  used,  if  avail¬ 
able,  to  get  tropopause  and  to 
convert  EL  units  from  pressure  to 
feet. 

WRKTPA 

Output 

Complete  stability  analysis  for  a 
single  station. 

WRKTPB 

Output 

Listing  of  significant  levels  and 
convectively  unstable  layers  for 
a  single  station. 

WRKTPC 

Output 

Tabular  listing  of  energy  indices 
for  list  specified  in  file  STNS1. 

WRKTPD 

Output 

Listing  of  missing  or  unuseable 

SGL  raob  reports.  ("C"  switch) 

NMCGPHEIS 

Output 

Graphic  with  plotted  values  of 

Ell  and  EL. 

LOAD  LINE: 


RLDR/P  RANP  DECOS  TEMPI  RANN2  CCL1  MODRB  INDX1  BNDX  UOBF  SATLFT  TCONOF 
UMROF  DPTOF  VAPFU  DECOM  IVCK  UND  HEIGHT  JREAL  FTCV 
CTPB  PULYR,  TP A,  STLOC  BNSCH,  GPT  ISCR  JSCR  MTITLH 
OUT  AFREAD.LB  ITCVT  FTCVT  TOP. LB  AG. LB  UTIL. LB  FORT. LB 


PROGRAM  INSTALLATION: 

1.  Add  CCCWRKTPA,  B,  C,  &  D to  database. 

Add  NMCGPHEIS  to  database  and  assign  map  background  2. 

2.  RANP.SV,  RANP.OL,  and  STNS1  should  be  on  DP0  or  DP0F  with 
link  to  DP0. 


EASTERN  REGION  CP  No.  16 


RANP 

STABILITY  ANALYSIS  PLOT  PROGRAM 


rvfRsrrv  0F  illinois-urbana 


3  0112 113036062 


PART  A:  PROGRAM  INFORMATION  AND  INSTALLATION  PROCEDURE  (RANP) 

PROGRAM  NAME:  RANP  AAL  ID: 

REVISION  NO.  1.00 

PURPOSE:  Uses  significant  level  raob  data  to  compute  the 

energy  indices  Ell  and  EI2  and  equilibrium  level 
EL  along  with  several  other  thermodynamic  parameters. 

PROGRAM  INFORMATION: 


NY 


Development  Programmer: 

Hugh  M.  Stone 
Location:  ERH  Garden  City, 

Phone:  ( FTS)  649-5443 
Language:  FORTRAN  IV 
Date:  2/84 

Running  Time: 

Single  station,  40  to  60  seconds 


Maintenance  Programmer: 
Same 


Type:  Standard 
Revision  Date:  NA 


32  stations. 

Disk  Space: 

about  8  minutes 

Program  Files 

122 

RDOS  blocks 

Overlay  Files 

- 

28 

RDOS  blocks 

Data  Files 

- 

3 

RDOS  blocks 

a  RAM  REQUIREMENTS: 

Program  Files:  RANP.SV  and 

RANP.OL 

Data  Files: 

Name 

DP  Location 

R/W 

Comments 

STNS1 

DP0 

Read 

List  of  raob  stations 

INDEXX 

DP0 

Wri  te 

(not  to  exceed  50) 
Temporary 

INDEXY 

DP0 

Write 

Temporary 

HMSGPH .01 

DP0 

Write 

Temporary 

